Forum Discussion
Copy specific data from one workbook to another
- Oct 03, 2019
Please find the attached with the code on Module1 and a button called "Generate Combined Membership Report" on Combined Report Sheet to run the code.
The code will open the file picker dialog box for you to pick the Membership Report first and then Service Report, once you pick both the files, the code will generate the combined report on the Combined Report Sheet.
Code on Module1:
Public Sub ExtractMembershipInfo() Dim wbCombined As Workbook Dim wbMembership As Workbook Dim wbService As Workbook Dim wsCombined As Worksheet Dim wsMember As Worksheet Dim wsService As Worksheet Dim strFilePath As String Dim x As Variant Dim y() As Variant Dim dict As Object Dim i As Long Application.ScreenUpdating = False Set wbCombined = ThisWorkbook Set wsCombined = wbCombined.Worksheets("Combined Report") With Application.FileDialog(msoFileDialogFilePicker) .Title = "Select Membership Report File!" .AllowMultiSelect = False .ButtonName = "Open Membership Report" .Filters.Clear .Filters.Add "Excel Files", "*.xlsx" If .Show = -1 Then strFilePath = .SelectedItems(1) Else MsgBox "You didn't select any Membership Report.", vbExclamation End End If End With Set wbMembership = Workbooks.Open(strFilePath) Set wsMember = wbMembership.Worksheets(1) With Application.FileDialog(msoFileDialogFilePicker) .Title = "Select Service Report File!" .AllowMultiSelect = False .ButtonName = "Open Service Report" .Filters.Clear .Filters.Add "Excel Files", "*.xlsx" If .Show = -1 Then strFilePath = .SelectedItems(1) Else MsgBox "You didn't select any Service Report.", vbExclamation End End If End With Set wbService = Workbooks.Open(strFilePath) Set wsService = wbService.Worksheets(1) Set dict = CreateObject("Scripting.Dictionary") x = wsMember.Range("A1").CurrentRegion.Value For i = 2 To UBound(x, 1) dict.Item(x(i, 1)) = x(i, 2) & "_" & x(i, 3) Next i wbMembership.Close False wsCombined.Cells.Clear wsService.Range("A1").CurrentRegion.Copy wsCombined.Range("A1") wbService.Close False x = wsCombined.Range("A1").CurrentRegion.Value ReDim y(1 To UBound(x, 1), 1 To 2) wsCombined.Cells(1, UBound(x, 2) + 1) = "Membership Type" wsCombined.Cells(1, UBound(x, 2) + 2) = "Membership Status" For i = 2 To UBound(x, 1) If dict.exists(x(i, 1)) Then y(i - 1, 1) = Split(dict(x(i, 1)), "_")(0) y(i - 1, 2) = Split(dict.Item(x(i, 1)), "_")(1) End If Next i wsCombined.Cells(2, UBound(x, 2) + 1).Resize(UBound(x, 1), 2).Value = y With wsCombined.Range("A1").CurrentRegion .Rows(1).Font.Bold = True .Rows(1).Font.Size = 13 .Columns.AutoFit .Borders.Color = vbBlack End With Application.ScreenUpdating = True End Sub
Thanks I have attached the sample files as requested.
I am have some basic knowledge of Macro but i have never used this. I am currently using excel 2010.
Many thanks
Kerrie
Please find the attached with the code on Module1 and a button called "Generate Combined Membership Report" on Combined Report Sheet to run the code.
The code will open the file picker dialog box for you to pick the Membership Report first and then Service Report, once you pick both the files, the code will generate the combined report on the Combined Report Sheet.
Code on Module1:
Public Sub ExtractMembershipInfo()
Dim wbCombined As Workbook
Dim wbMembership As Workbook
Dim wbService As Workbook
Dim wsCombined As Worksheet
Dim wsMember As Worksheet
Dim wsService As Worksheet
Dim strFilePath As String
Dim x As Variant
Dim y() As Variant
Dim dict As Object
Dim i As Long
Application.ScreenUpdating = False
Set wbCombined = ThisWorkbook
Set wsCombined = wbCombined.Worksheets("Combined Report")
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select Membership Report File!"
.AllowMultiSelect = False
.ButtonName = "Open Membership Report"
.Filters.Clear
.Filters.Add "Excel Files", "*.xlsx"
If .Show = -1 Then
strFilePath = .SelectedItems(1)
Else
MsgBox "You didn't select any Membership Report.", vbExclamation
End
End If
End With
Set wbMembership = Workbooks.Open(strFilePath)
Set wsMember = wbMembership.Worksheets(1)
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select Service Report File!"
.AllowMultiSelect = False
.ButtonName = "Open Service Report"
.Filters.Clear
.Filters.Add "Excel Files", "*.xlsx"
If .Show = -1 Then
strFilePath = .SelectedItems(1)
Else
MsgBox "You didn't select any Service Report.", vbExclamation
End
End If
End With
Set wbService = Workbooks.Open(strFilePath)
Set wsService = wbService.Worksheets(1)
Set dict = CreateObject("Scripting.Dictionary")
x = wsMember.Range("A1").CurrentRegion.Value
For i = 2 To UBound(x, 1)
dict.Item(x(i, 1)) = x(i, 2) & "_" & x(i, 3)
Next i
wbMembership.Close False
wsCombined.Cells.Clear
wsService.Range("A1").CurrentRegion.Copy wsCombined.Range("A1")
wbService.Close False
x = wsCombined.Range("A1").CurrentRegion.Value
ReDim y(1 To UBound(x, 1), 1 To 2)
wsCombined.Cells(1, UBound(x, 2) + 1) = "Membership Type"
wsCombined.Cells(1, UBound(x, 2) + 2) = "Membership Status"
For i = 2 To UBound(x, 1)
If dict.exists(x(i, 1)) Then
y(i - 1, 1) = Split(dict(x(i, 1)), "_")(0)
y(i - 1, 2) = Split(dict.Item(x(i, 1)), "_")(1)
End If
Next i
wsCombined.Cells(2, UBound(x, 2) + 1).Resize(UBound(x, 1), 2).Value = y
With wsCombined.Range("A1").CurrentRegion
.Rows(1).Font.Bold = True
.Rows(1).Font.Size = 13
.Columns.AutoFit
.Borders.Color = vbBlack
End With
Application.ScreenUpdating = True
End Sub
- Kerrie1383Oct 03, 2019Copper Contributor
OMG this is amazing, it worked on the sample sheets but not on the original reports, I assume this is because the samples did not include all data as per the original report.
I did however match the fields and it seemed worked... so I have just sort the list ascending by name and copy and paste on to the original report.
Thank you so much for your help, I really appreciate it.
Kindest regards
K
- Subodh_Tiwari_sktneerOct 03, 2019Silver Contributor
You're welcome! Glad it worked as desired and you were able to tweak it as per your need.
Please take a minute to select the post with the proposed solution as a Best Response/Answer to mark your question as Solved.