asked on

Copy the TAB Names from a workbook to a column of another workbook

Hi Everyone,

The below code copys the column of different tab from a WorkbookA to a tab 'Log' of a workbookB.

Column A(WorkbookB) is the sr no. Column B(WorkbookB) is Column G of Workbook A. Column C(WorkbookB) is Column D of WorkbookA. Column D(WorkbookB) is Column F of workbookA. Column E(WorkbookB) is Column E of WorkbookA and when the Column J of Workbook A has "Yes".

Addition to the code:

I just want to add a column to WorkbookB that will display the Tab Name of the WorkbookA from which the rows are being copied from. Highlighted the column

Sub movedata()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb As Workbook
Dim wb1 As Workbook
Dim wk As Worksheet
Dim xpath As String

Set wb = ThisWorkbook
xpath = ThisWorkbook.Path
Set wk = Sheets("Log")

Set wb1 = Workbooks.Open(xpath & "\Workbook-A.xlsx")

wk.Move After:=wb1.Sheets(wb1.Sheets.Count)

Dim ws1 As Worksheet
Dim lrow As Long, cell As Range, rng As Range
Dim lr As Long
Set ws1 = Sheets("Log")

lr = ws1.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

If lr > 2 Then ws1.Range("A3:E" & lr).Clear '<=If you dont want to clear old data from sheet log then remove this line

For Each ws In wb1.Worksheets
If ws.Name <> ws1.Name Then
lrow = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row
If lrow > 5 Then
Set rng = ws.Range("J6:J" & lrow)

For Each cell In rng

lr = ws1.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

'If UCase(Trim(cell.Value)) = "YES" Then'
ws1.Range("A" & lr).Value = Application.WorksheetFunction.Max(ws1.Range("a:a")) + 1
ws1.Range("b" & lr).Value = ws.Range("G" & cell.Row).Value
ws1.Range("C" & lr).Value = ws.Range("D" & cell.Row).Value
ws1.Range("D" & lr).Value = ws.Range("F" & cell.Row).Value
ws1.Range("E" & lr).Value = ws.Range("E" & cell.Row).Value
'End If'

Next cell

End If
End If

Next ws

ws1.Move After:=wb.Sheets(wb.Sheets.Count)

wb1.Close (False)
wb.Save

End Sub
Workbook-A.xlsm
Workbook-B.xlsm

Shums Faruk

Please try below in your Workbook B module:

Sub movedata()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim wb As Workbook
    Dim wb1 As Workbook
    Dim wk As Worksheet
    Dim xpath As String

    Set wb = ThisWorkbook
    xpath = ThisWorkbook.Path
    Set wk = Sheets("Log")

    Set wb1 = Workbooks.Open(xpath & "\Workbook-A.xlsm")

    wk.Move After:=wb1.Sheets(wb1.Sheets.Count)

    Dim ws1 As Worksheet
    Dim lrow As Long, cell As Range, rng As Range
    Dim lr As Long
    Set ws1 = Sheets("Log")

    lr = ws1.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    If lr > 2 Then ws1.Range("A3:E" & lr).Clear    '<=If you dont want to clear old data from sheet log then remove this line

    For Each ws In wb1.Worksheets
        If ws.Name <> ws1.Name Then
            lrow = ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If lrow > 5 Then
                Set rng = ws.Range("J6:J" & lrow)

                For Each cell In rng

                    lr = ws1.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

                    'If UCase(Trim(cell.Value)) = "YES" Then'
                    ws1.Range("A" & lr).Value = Application.WorksheetFunction.Max(ws1.Range("a:a")) + 1
                    ws1.Range("b" & lr).Value = ws.Range("G" & cell.Row).Value
                    ws1.Range("C" & lr).Value = ws.Range("D" & cell.Row).Value
                    ws1.Range("D" & lr).Value = ws.Range("F" & cell.Row).Value
                    ws1.Range("E" & lr).Value = ws.Range("E" & cell.Row).Value
                    'End If'
                    ws1.Range("B" & lr) = ws.Name


                Next cell

            End If
        End If

    Next ws


    ws1.Move After:=wb.Sheets(wb.Sheets.Count)

    wb1.Close (False)
    wb.Save

End Sub

Open in new window

Shums Faruk

Where do you want sheets name? As I understood, you wanted in Column B which is highlighted, if yes, then you are replacing this line of your code:

ws1.Range("b" & lr).Value = ws.Range("G" & cell.Row).Value

Open in new window

Milind Agarwal

ASKER

Hi Shums,

It works great!! just a minor update. I would like to exclude few tabs. What changes do we need to make to the code? Like for example I would like to exclude 'AC' tab and the content in that Tab.

Thanks,

Shums Faruk

If you want to exclude tab ac then use below code:

Sub movedata()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim wb As Workbook
    Dim wb1 As Workbook
    Dim wk As Worksheet
    Dim xpath As String

    Set wb = ThisWorkbook
    xpath = ThisWorkbook.Path
    Set wk = Sheets("Log")

    Set wb1 = Workbooks.Open(xpath & "\Workbook-A.xlsm")

    wk.Move After:=wb1.Sheets(wb1.Sheets.Count)

    Dim ws1 As Worksheet
    Dim lrow As Long, cell As Range, rng As Range
    Dim lr As Long
    Set ws1 = Sheets("Log")

    lr = ws1.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    If lr > 2 Then ws1.Range("A3:E" & lr).Clear    '<=If you dont want to clear old data from sheet log then remove this line

    For Each ws In wb1.Worksheets
        If ws.Name <> ws1.Name And ws.Name <> "ac" Then
            lrow = ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If lrow > 5 Then
                Set rng = ws.Range("J6:J" & lrow)

                For Each cell In rng

                    lr = ws1.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

                    'If UCase(Trim(cell.Value)) = "YES" Then'
                    ws1.Range("A" & lr).Value = Application.WorksheetFunction.Max(ws1.Range("a:a")) + 1
                    ws1.Range("b" & lr).Value = ws.Range("G" & cell.Row).Value
                    ws1.Range("C" & lr).Value = ws.Range("D" & cell.Row).Value
                    ws1.Range("D" & lr).Value = ws.Range("F" & cell.Row).Value
                    ws1.Range("E" & lr).Value = ws.Range("E" & cell.Row).Value
                    'End If'
                    ws1.Range("B" & lr) = ws.Name


                Next cell

            End If
        End If

    Next ws


    ws1.Move After:=wb.Sheets(wb.Sheets.Count)

    wb1.Close (False)
    wb.Save

End Sub

Open in new window

ASKER CERTIFIED SOLUTION

Shums Faruk

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Milind Agarwal

ASKER

Thanks Shums

Shums Faruk

You'r welcome Milind! Glad I was able to help you :)