Forum Discussion

Kerrie1383's avatar
Kerrie1383
Copper Contributor
Oct 02, 2019
Solved

Copy specific data from one workbook to another

Hi, Can anyone kindly offer some advice on the following?...... I have two reports with different data, one for members and one for those who have used our services (both have the name column). Wha...
  • Subodh_Tiwari_sktneer's avatar
    Subodh_Tiwari_sktneer
    Oct 03, 2019

    Kerrie1383 

    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

     

     

Resources