AbdulHafeezRauf
New Member
- Joined
- Sep 1, 2022
- Messages
- 3
- Office Version
- 2016
- Platform
- Windows
I have been using below code to copy data based on column headers, but now I would like to copy data from multiple sheet & paste to same number of sheet. I have tried For...Next statement but it didn't work. Please help.
Public Sub CopyProjectName()
Dim sourceWS As Worksheet, targetWS As Worksheet
Dim lastCol As Long, lastRow As Long, srcRow As Range
Dim found1 As Range, found2 As Range, j As Long, Cr1 As String
Set sourceWS = Workbooks("Workbook1.xlsm").Worksheets("Sheet1") 'Needs to be open
Set targetWS = Workbooks("Workbook2.xlsm").Worksheets("Sheet1") 'Needs to be open
With sourceWS
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
For j = 1 To lastCol
Cr1 = .Cells(1, j).Value
Set srcRow = .Range("A1", .Cells(1, lastCol))
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)
If Not found1 Is Nothing Then
lastCol = targetWS.Cells(1, Columns.Count).End(xlToLeft).Column
Set srcRow = targetWS.Range("A1", targetWS.Cells(1, lastCol))
Set found2 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)
If Not found2 Is Nothing Then
lastRow = .Cells(Rows.Count, found1.Column).End(xlUp).Row
.Range(.Cells(2, found1.Column), .Cells(lastRow, found1.Column)).Copy
found2.Offset(1, 0).PasteSpecial xlPasteAll
End If
End If
Next j
End With
End Sub
Public Sub CopyProjectName()
Dim sourceWS As Worksheet, targetWS As Worksheet
Dim lastCol As Long, lastRow As Long, srcRow As Range
Dim found1 As Range, found2 As Range, j As Long, Cr1 As String
Set sourceWS = Workbooks("Workbook1.xlsm").Worksheets("Sheet1") 'Needs to be open
Set targetWS = Workbooks("Workbook2.xlsm").Worksheets("Sheet1") 'Needs to be open
With sourceWS
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
For j = 1 To lastCol
Cr1 = .Cells(1, j).Value
Set srcRow = .Range("A1", .Cells(1, lastCol))
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)
If Not found1 Is Nothing Then
lastCol = targetWS.Cells(1, Columns.Count).End(xlToLeft).Column
Set srcRow = targetWS.Range("A1", targetWS.Cells(1, lastCol))
Set found2 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)
If Not found2 Is Nothing Then
lastRow = .Cells(Rows.Count, found1.Column).End(xlUp).Row
.Range(.Cells(2, found1.Column), .Cells(lastRow, found1.Column)).Copy
found2.Offset(1, 0).PasteSpecial xlPasteAll
End If
End If
Next j
End With
End Sub