I have a Master File and Source File.
Master File: multiple worksheets, Column A to J
Source File: multiple worksheets, Column A to E
I have managed to come out with
1) Prompt window to select Source File
2) Copy Column C, D, E from Source File and Paste it to Column C, D, E by matching value in Column A within a worksheet
I am now trying to repeat this copy-paste in multiple worksheets.
The worksheet name ranges from "F.01, F.02 to F.10", "T.01, T.02 to T.10", "IS.01 to IS.05" for both Master and Source File.
I am a newbie in VBA - I managed to get below code done by checking all forums and forums.
Really need your help in helping me to code something along the line making it Copy-Paste to be repetitive based on range of worksheets as stated above.
Source "F.01" to Master "F.01" and it goes on
Sub CommandButton2_Click()
Dim fileDialog As fileDialog
Dim strPathFile As String
Dim strFileName As String
Dim strPath As String
Dim dialogTitle As String
Dim wbSource As Workbook
Dim rngToCopy As Range
Dim rngRow As Range
Dim rngDestin As Range
Dim lngRowsCopied As Long
Dim dic As Object
Dim ky As Variant
Dim c As Variant
Dim cel As Range
Dim x As String
Dim tgt As Range
Dim FR As Long
Dim SSheetList As Variant
Dim MSheetList As Variant
dialogTitle = "Navigate to and select required file."
Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
With fileDialog
.InitialFileName = "C:\Users\User\Documents"
'.InitialFileName = ThisWorkbook.Path & "\" 'Alternative to previous line
.AllowMultiSelect = False
.Filters.Clear
.Title = dialogTitle
If .Show = False Then
MsgBox "File not selected to import. Process Terminated"
Exit Sub
End If
strPathFile = .SelectedItems(1)
End With
Set wbSource = Workbooks.Open(Filename:=strPathFile)
SSheetList = Array("F.01", "F.02")
MSheetList = Array("F.01", "F.02")
Set sh1 = ThisWorkbook.Sheets(MSheetList)
Set sh2 = wbSource.Sheets(SSheetList)
Application.ScreenUpdating = False
If sh1 Is sh2 Then
For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))
FR = 0
On Error Resume Next
FR = Application.Match(c, sh1.Columns(1), 0)
On Error GoTo 0
If FR <> 0 Then sh1.Range("C" & FR).Value = c.Offset(, 2)
If FR <> 0 Then sh1.Range("D" & FR).Value = c.Offset(, 3)
If FR <> 0 Then sh1.Range("E" & FR).Value = c.Offset(, 4)
Next c
End If
wbSource.Close SaveChanges:=False
Set fileDialog = Nothing
Set rngRow = Nothing
Set rngToCopy = Nothing
Set wbSource = Nothing
Set rngDestin = Nothing
'MsgBox "The data is copied"
End Sub
I have modified your code, please try this:
Sub CommandButton2_Click()
Dim fileDialog As fileDialog
Dim strPathFile As String
Dim strFileName As String
Dim strPath As String
Dim dialogTitle As String
Dim wbSource As Workbook
Dim wbMaster As Workbook
Dim wsSource, wsMaster As Worksheet
Dim rngToCopy As Range
Dim rngRow As Range
Dim rngDestin As Range
Dim lngRowsCopied As Long
Dim dic As Object
Dim ky As Variant
Dim c As Variant
Dim cel As Range
Dim x As String
Dim tgt As Range
Dim FR
Set wbMaster = ThisWorkbook.Name
dialogTitle = "Navigate to and select required file."
Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
With fileDialog
.InitialFileName = "C:\Users\User\Documents"
'.InitialFileName = ThisWorkbook.Path & "\" 'Alternative to previous line
.AllowMultiSelect = False
.Filters.Clear
.Title = dialogTitle
If .Show = False Then
MsgBox "File not selected to import. Process Terminated"
Exit Sub
End If
strPathFile = .SelectedItems(1)
End With
''''''''
'this is what I've modified:
Set wbSource = Workbooks.Open(Filename:=strPathFile)
For Each wsSource In wbSource.Sheets
For Each wsMaster In wbMaster.Sheets
If wsSource.Name = wsMaster.Name Then
t = 2
Do Until t = wbSource.wsSource.Cells(Rows.Count, 1).End(xlUp).Row
c = wbSource.wsSource.Cells(t, 1).Value
Set FR = wbMaster.wsMaster.Columns(1).Find(What:=c)
If Not FR Is Nothing Then
Do Until FR Is Nothing
wbMaster.wsMaster.Cells(FR.Row, 3).Value = wbSource.wsSource.Cells(t, 2).Value
'Or
'wbMaster.wsMaster.Cells(FR.Row, 3).Copy
'wbSource.wsSource.Cells(t, 2).PasteSpecial Paste:=xlPasteValues
wbMaster.wsMaster.Cells(FR.Row, 4).Value = wbSource.wsSource.Cells(t, 3).Value
wbMaster.wsMaster.Cells(FR.Row, 5).Value = wbSource.wsSource.Cells(t, 4).Value
Loop
End If
t = t + 1
Loop
End If
Next wsMaster
Next wsSource
''''''''
wbSource.Close SaveChanges:=False
Set fileDialog = Nothing
Set rngRow = Nothing
Set rngToCopy = Nothing
Set wbSource = Nothing
Set rngDestin = Nothing
'MsgBox "The data is copied"
End Sub
Found a solution to it
Sub CommandButton2_Click()
Dim fileDialog As fileDialog
Dim strPathFile As String
Dim dialogTitle As String
Dim wbSource As Workbook, Mwb As Workbook
Dim Ws As Worksheet, Mws As Worksheet
Dim Cl As Range
Dim FR As Long
Set Mwb = ThisWorkbook
dialogTitle = "Navigate to and select required file."
Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
With fileDialog
.InitialFileName ="C:\Users\User\Documents"
.AllowMultiSelect = False
.Filters.Clear
.Title = dialogTitle
If .Show = False Then
MsgBox "File not selected to import. Process Terminated"
Exit Sub
End If
strPathFile = .SelectedItems(1)
End With
Application.ScreenUpdating = False
Set wbSource = Workbooks.Open(FileName:=strPathFile)
For Each Ws In wbSource.Worksheets
If ShtExists(Ws.name, Mwb) Then
Set Mws = Mwb.Sheets(Ws.name)
For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
FR = 0
On Error Resume Next
FR = Application.Match(Cl.Value, Ws.Columns(1), 0)
On Error GoTo 0
If FR <> 0 Then Mws.Range("C" & FR).Value = Cl.Offset(, 2)
If FR <> 0 Then Mws.Range("D" & FR).Value = Cl.Offset(, 3)
If FR <> 0 Then Mws.Range("E" & FR).Value = Cl.Offset(, 4)
Next Cl
End If
Set Mws = Nothing
Next Ws
wbSource.Close SaveChanges:=False
End Sub
Public Function ShtExists(ShtName As String, Optional Wbk As Workbook) As Boolean
If Wbk Is Nothing Then Set Wbk = ActiveWorkbook
On Error Resume Next
ShtExists = (LCase(Wbk.Sheets(ShtName).name) = LCase(ShtName))
On Error GoTo 0
End Function
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.