'macro Find same cell in two workbooks and copy other cell behind found cell
I have one masterfile and one folder with many documents. In the masterfile there is a list of names. In the other documents there are also names and numbers behind the names (Cell E10:F29). I want to open each the file in the folder and search same names from this document in the masterfile. If the names are identical i want to copy the number behind the document in the cell behind the found cell in the masterfile. It should loop through the document from E10 to E29. If that's done it should close the document and open the next one in the folder.
So fare I can open several documents in the folder and do something with it. Additionally I tried several codes to find identical text. There I have already problems that the code is working. I don't have any code of copying the number behind the found cell.
Any help why find function isn't working or how i could write the copy code?
Dim name_master As Range
Set name_master = Range("D292:D361") ' names in masterfile
Dim firstAddress As String
Dim name_number As Integer
Dim path As String
Dim Filename As String
'open masterfile
Workbooks.Open Filename:="/Users/masterfile.xlsx"
Set Samplelist = Workbooks("masterfile.xlsx")
' set paht for folder with several documents
path = "/Users/folder/"
Extension = "*.xlsx" 'format of documents
Dim strFile As String
searchValue = Range("E10")
name_number = 6 ' the copied cell should be paste in column F
r = 292 ' the copied cell should be paste in cell 292
' Loop mache etwas solange es Daten in dem vordefinierten Pfad hat
If path = "" Then
Exit Sub
Else
strFile = Dir(path & Extension)
Do While Len(strFile) > 0
Workbooks.Open Filename:=path & strFile ' open first document in folder
' go to first name and search the same name in masterfile
Workbooks(strFile).Activate
With Samplelist
Set name_master = .Find(searchValue, LookIn:=xlValues)
If Not name_master Is Nothing Then
' find same names
firstAddress = name_master.Address
Do
MsgBox "It found identical cell" & Range("E10").Value
' when it is working so fare, hear would be the code for copying number to the correct cell
' search till no match is found
Set name_master = .FindNext(name_master)
Loop While Not name_master Is Nothing And art_taxon.Address <> firstAddress
End If
End With
' close all documents
Workbooks(strFile).Activate
Workbooks(strFile).Close
strFile = Dir()
Loop
End If
End Sub
Solution 1:[1]
Multiple Workbooks Data Transfer
Read Assumnptions and adjust the values in the Constants section.
The Code
Option Explicit
' Assumptions:
' - The file containing this code is one level above the 'Users' Folder.
' - There is maximally one occurrence of a name in the source worksheets.
' If there is more occurrences, another loop has to be implemented instead
' of the 'Application.Match' solution.
' - All source worksheets have the same name. If not, worksheet
' indexes (Variant) can be used instead of the names, e.g. 1 or 2 or 3 etc.,
' but they have to be the same for all source worksheets.
Sub copyMultiData()
Const srcPath As String = "Users\folder" ' Source Path
Const srcExtension As String = "*.xlsx" ' Source File Extension
Const srcName As Variant = "Sheet1" ' Source Worksheet Name/Index
Const srcLookUpRange As String = "E10:E29" ' Source LookUp Range Address
Const srcValueColumn As Long = 6 ' Source Value Column
Const tgtPathName As String = "Users\masterfile.xlsx" ' Source File Path
Const tgtName As Variant = "Sheet1" ' Target Worksheet Name/Index
Const tgtLookUpRange As String = "D292:D361" ' Target LookUp Range Address
Const tgtValueColumn As Long = 6 ' Target Value Column
Dim srcWB As Workbook ' Source Workbook
Dim srcWS As Worksheet ' Source Worksheet
Dim srcLookUp As Variant ' Source LookUp Array
Dim srcValue As Variant ' Source Value Array
Dim srcFile As String ' Current Source File Name
Dim tgtWB As Workbook ' Target Workbook
Dim tgtWS As Worksheet ' Target Worksheet
Dim tgtLookup As Variant ' Target LookUp Array
Dim tgtValue() As Double ' Target Value Array
Dim tgtUB As Long ' Target Number of Elements (Rows)
Dim tgtCounter As Long ' Target Arrays Elements (Rows) Counter
' Copy values from Target LookUp Range to Target LookUp Array.
Set tgtWB = Workbooks.Open(Filename:=ThisWorkbook.path _
& Application.PathSeparator & tgtPathName) ' Define workbook.
Set tgtWS = tgtWB.Worksheets(tgtName) ' Define worksheet.
tgtLookup = tgtWS.Range(tgtLookUpRange) ' Copy range to array.
' Define Target Number of Elements (rows) of both Target Arrays.
tgtUB = UBound(tgtLookup)
' Initialize and resize Target Value Array to the same size as
' Target LookUp Array.
ReDim tgtValue(1 To tgtUB, 1 To 1)
' Loop through files in Source Path.
srcFile = Dir(ThisWorkbook.path & Application.PathSeparator & srcPath _
& Application.PathSeparator & srcExtension)
Do While Len(srcFile) > 0
' Copy values from Source Ranges to Source Arrays.
Set srcWB = Workbooks.Open(Filename:=ThisWorkbook.path _
& Application.PathSeparator & srcPath & Application.PathSeparator _
& srcFile) ' Define workbook.
Set srcWS = srcWB.Worksheets(srcName) ' Define worksheet.
With srcWS.Range(srcLookUpRange)
srcLookUp = .Value ' Copy range to array.
srcValue = .Offset(, srcValueColumn - .Column).Value ' The same.
End With
' Loop through elements (rows) of Target LookUp Array.
For tgtCounter = 1 To tgtUB
' Try to find a match in Source LookUp Array.
If Not IsError( _
Application.Match(tgtLookup(tgtCounter, 1), srcLookUp, 0)) Then
' Add value (sum) of found element in Source Value Array
' to previous value of current element in Target Value Array.
tgtValue(tgtCounter, 1) = tgtValue(tgtCounter, 1) + srcValue( _
Application.Match(tgtLookup(tgtCounter, 1), srcLookUp, 0), 1)
Else ' No match (not found).
End If
Next tgtCounter
srcWB.Close False ' 'False' means do not save changes.
srcFile = Dir()
Loop
' Copy values of Target Value Array to Target Value Range.
With tgtWS.Range(tgtLookUpRange)
' Possible previous values will be overwritten (no need to clear).
.Offset(, tgtValueColumn - .Column).Value = tgtValue
End With
' Choose either:
'tgtWB.Close True ' Save & Close ('True' means save changes).
' or one of the following:
'tgtWB.Save ' Save
'tgtWB.Close ' Close
MsgBox "Master Workbook successfully updated.", vbInformation
End Sub
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 | VBasic2008 |
