CODEWITHSUNDEEP
vbaexcelexcel-2007
Manivannan KG
Manivannan KG

Reputation: 371

VBA-Copy specific Column Data from multiple worksheets into one

I have a very typical scenario where two columns from different worksheets(in same workbook) needs to be copied to single worksheet.

Source workbook name: Mycalc.xlsm

Worksheets name: Sheet1, sheet2, sheet3 (There are other sheets as well but action t o be performed only for the mentioned)

Target Workbook Name: Mycalc.xlsm

Target worksheet name: Merged

Condition:

  1. Cannot do for each for all worksheets in the the workbook as the action to be performed only on the mentioned three sheets.
  2. The columns headers are not necessarily in same order in all sheets but the header is same.

enter image description here enter image description here enter image description here

Result Expected: The resultant is a consolidated data from all 3 sheets along with a column sheetname mentioning the sheet where data copied.

I am no expert in this and hence i am not pasting the code whatever i have achieved. Adding to it, I have approached by adding the sheet name in a named range as list (in a workbook i created a table having the list of sheet names and for each is performed on that range).

enter image description here

The experts of stackoverflow, please help me.

Regards,

Mani

Upvotes: 0

Views: 5390

Answers (2)

Manivannan KG
Manivannan KG

Reputation: 371

I have used the concept of named range for the sheet names. After lot of hurdles and time consuming research. Here is a simple, compiles and working code.

Public Sub ExportData()

Dim TransCol(1 To 2) As String
Dim ImportWS As Worksheet
Dim SheetsName As Range
Dim FindColumn, TargetColumn As Range
Dim RowCount As Long
Dim RowIndex, i, Column  As Long
Dim LastUsedRow As Long
Dim LastUsedRowCount As Variant


    TransCol(1) = "ISIN"
    TransCol(2) = "Current Day Adjustment"



For Each SheetsName In sheet3.Range("tblSheetNames").Cells

 If Len(SheetsName.Value) > 0 Then

 Set ImportWS = ThisWorkbook.Sheets(SheetsName.Value)
 ImportWS.Activate

 For Column = 1 To 2

 Set FindColumn = ImportWS.Cells.Find(TransCol(Column), searchorder:=xlByRows, searchdirection:=xlNext)
     RowCount = FindColumn.Cells(200000, 1).End(xlUp).Row
 Set TargetColumn = sheet3.Cells.Find(TransCol(Column), searchorder:=xlByRows, searchdirection:=xlNext)

For i = FindColumn.Row To RowCount

    LastUsedRow = sheet3.Cells(200000, TargetColumn.Column).End(xlUp).Row
    sheet3.Cells(LastUsedRow + 1, TargetColumn.Column).Value = ImportWS.Cells(i + 1, FindColumn.Column).Value

 Next i

 Next Column
End If

Next
End Sub

**Note:**I have moved the code to the module than the workbook code behind.

Happy to explain, if more info is required. Thank you All.

Regards,

Mani

Upvotes: 1

user3819867
user3819867

Reputation: 1120

You don't deserve a sub from scratch, made no uniformization or efforts otherwise to get anywhere.
Since you're apparently not intending to learn either I didn't really bother commenting the code. If I'm wrong and you would like to learn what these lines are doing feel free to comment under and I'll respond.

Sub ertdfgcvb()
ExportWS = "Merged"
Dim ImportWS(1 To 3) As String
    ImportWS(1) = "Sheet1"
    ImportWS(2) = "sheet2"
    ImportWS(3) = "sheet3"
Dim TransCol(1 To 2) As String
    TransCol(1) = "Current Day Adjustment"
    TransCol(2) = "ISIN"
For i = 1 To 3 'for each import sheet
    FirstImportRow = Worksheets(ImportWS(i)).Cells.Find(TransCol(1), SearchOrder:=xlByRows, SearchDirection:=xlNext).Row + 1
    LastImportRow = Worksheets(ImportWS(i)).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    DiffRows = LastImportRow - FirstImportRow
    FirstExportRow = Worksheets(ExportWS).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    ExportColumn = Worksheets(ExportWS).Cells.Find("Sheet Name", SearchOrder:=xlByRows, SearchDirection:=xlNext).Column 'defines where to insert the sheet name
    Worksheets(ExportWS).Range(Cells(FirstExportRow, ExportColumn), Cells(FirstExportRow + DiffRows, ExportColumn)) = ImportWS(i)
    For j = 1 To 2 'for each column that has to be transported
        ExportColumn = Worksheets(ExportWS).Cells.Find(TransCol(j), SearchOrder:=xlByRows, SearchDirection:=xlNext).Column 'defines where to insert the data
        ImportColumn = Worksheets(ImportWS(i)).Cells.Find(TransCol(j), SearchOrder:=xlByRows, SearchDirection:=xlNext).Column 'defines where to insert the data from
        For k = 0 To DiffRows
            Worksheets(ExportWS).Cells(FirstExportRow + k, ExportColumn) = Worksheets(ImportWS(i)).Cells(FirstImportRow + k, ImportColumn)
        Next
    Next

Next
End Sub

Upvotes: 0

Related Questions