vba - copy specific column data from multiple sheets from source workbook into a destination workbook from where I write the macro

vijkar2008

New Member
Joined
Feb 9, 2022
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Hello!
I am new to vba coding and I need this macro to copy specific columns data consolidated from multiple sheets into one sheet.
Criteria :
1. Following are the column headers to search in multiple sheets - "Line of Business", "Tracking Numbers", "Legal Entity", "License", "Product", "Product Type", "Current Plan Code", "Plan Category", "Description", "Standards", "PCP Kids's Copay Designated Network", "Kid's Copay Age Limit Designated Network", "PCP Kid's Copay Network", "Kid's Copay Age Limit Network", "PCP Visit Limits", "URG CARE Visit Limits", "ER Visit Limits", "Acupuncture Copay", "Acupuncture Visit Limit", "Med/Rx Deductible Type", "Medical Deductible Type", "Market Code"
2. Copy multiple sheets data from source file matching above columns and paste (consolidated) to a separate workbook or on the destination sheet where I write macro.
3. I tried the below code where all data is copied from all sheets, but I couldn't figure out how to search and copy only specified columns. Also, I need to traverse multiple sheets until or before 'Rx Standards' sheet. I do not need anything from Rx Standards or sheets after it.

Private Sub CommandButton1_Click()
Workbooks.Open Filename:="C:\....\.....\.....\....\aaaaa.xlsx"
Worksheets.Add Sheets(1)
ActiveSheet.Name = "PH"
For A = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If A > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(A).Activate
ActiveSheet.UsedRange.Copy xRg
Next
Application.ScreenUpdating = True
Worksheets("PH").Activate
MsgBox ("Done")
End sub

4. I tried another way where I have all the sheets in the same workbook where I write macro. Where I couldn't figure out a way to reset the Receiver array to point to the next blank row to copy data into. And so it overwrites the copied data to same position in the destination.

Private Sub CommandButton2_Click()
Dim Current As Worksheet, CR As Long
For Each Current In Worksheets

Dim Sht1 As Worksheet, Sht2 As Worksheet, FindRng As Range, Fnd As Range, Headers As Variant, Receivers As Variant, lR As Long
Headers = Array("Line of Business", "Tracking Numbers", "Legal Entity", "License", "Product", "Product Type", "Current Plan Code", "Plan Category", "Description", "Standards", "PCP Kids's Copay Designated Network", "Kid's Copay Age Limit Designated Network", "PCP Kid's Copay Network", "Kid's Copay Age Limit Network", "PCP Visit Limits", "URG CARE Visit Limits", "ER Visit Limits", "Acupuncture Copay", "Acupuncture Visit Limit", "Med/Rx Deductible Type", "Medical Deductible Type", "Market Code")
Receivers = Array("A3", "B3", "C3", "D3", "E3", "G3", "H3", "I3", "J3", "K3", "L3", "M3", "N3", "O3", "P3", "Q3", "R3", "S3", "T3", "U3", "V3", "W3")
Set Sht1 = Current: Set Sht2 = Sheets("PH")

Set FindRng = Intersect(Sht1.Rows(1), Sht1.Columns("A:ZZ"))
Application.ScreenUpdating = False
For I = LBound(Headers) To UBound(Headers)
Set Fnd = FindRng.Find(Headers(I))

If Not Fnd Is Nothing Then
lR = Sht1.Cells(Sht1.Rows.Count, Fnd.Column).End(xlUp).Row
Sht1.Range(Fnd, Sht1.Cells(lR, Fnd.Column)).Copy destination:=Sht2.Range(Receivers(I))
End If
Next I
Next
Application.ScreenUpdating = True
MsgBox ("Done")
End Sub

Please help me. I prefer the way mentioned in 3# where it creates separate workbook to avoid any data mess. I would appreciate any help. Thank you all for your help in advance!
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top