Actively Copy Cells From Multiple Worksheets

[Ryusui]

Hey all. I'm trying to create a worksheet which copies 3 different cells over all sheets in that workbook. I know I can use INDIRECT, but that only works if I manually input that formula once for each worksheet I want to reference. I want the worksheet to automatically add or remove the data if a worksheet is added or removed.


As an example, this site shows how to actively create a list of all the workbook's sheet names:

List sheet names with formula

To list worksheets in an Excel workbook with a formula, you can use a 2-step approach: (1) define a named range called "sheetnames" with an old macro command and (2) use the TEXTAFTER function and the TRANSPOSE function to retrieve sheet names using the name. In the example shown, the formula in...

exceljet.net

If you add a worksheet, that new sheet is added to the list of names. If you delete one, that worksheet is removed from the list. I want to do the same thing, but with cell values instead of sheet names.


Any suggestions? Thanks!

 

[Logit]

VBA solution :

Sub CopyDataToSheet1()
    Dim ws As Worksheet
    Dim destSheet As Worksheet
    Dim destRow As Long
    
    Set destSheet = ThisWorkbook.Sheets("Sheet1")
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> destSheet.Name Then
            destRow = destSheet.Cells(destSheet.Rows.Count, 1).End(xlUp).Row + 1
            destSheet.Cells(destRow, 1).Value = ws.Range("A2").Value
            destSheet.Cells(destRow, 2).Value = ws.Range("C3").Value
            destSheet.Cells(destRow, 3).Value = ws.Range("D4").Value
        End If
    Next ws
End Sub

 

[Fuji]

Hey all. I'm trying to create a worksheet which copies 3 different cells over all sheets in that workbook. I know I can use INDIRECT, but that only works if I manually

If you add a worksheet, that new sheet is added to the list of names. If you delete one, that worksheet is removed from the list. I want to do the same thing, but with cell values instead of sheet names.

Right click on the sheet tab that you want to create the list and paste the code.
Code runs each time you select that sheet.

Private Sub Worksheet_Activate()
    Dim x, i&, ws As Worksheet
    Application.ScreenUpdating = False
    x = Array("A1", "C1", "G2") '<--- Add/Remove/Change as you wish
    [a1].CurrentRegion.ClearContents
    [a1] = "Sheet Name"
    [b1].Resize(, UBound(x) + 1) = x
    For Each ws In Worksheets
        If ws.Name <> Me.Name Then
            With Range("a" & Rows.Count).End(xlUp)(2)
                .Value = ws.Name
                For i = 0 To UBound(x)
                    .Cells(1, i + 2) = ws.Range(x(i))
                Next
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[Ryusui]

Right click on the sheet tab that you want to create the list and paste the code.
Code runs each time you select that sheet.

Private Sub Worksheet_Activate()
    Dim x, i&, ws As Worksheet
    Application.ScreenUpdating = False
    x = Array("A1", "C1", "G2") '<--- Add/Remove/Change as you wish
    [a1].CurrentRegion.ClearContents
    [a1] = "Sheet Name"
    [b1].Resize(, UBound(x) + 1) = x
    For Each ws In Worksheets
        If ws.Name <> Me.Name Then
            With Range("a" & Rows.Count).End(xlUp)(2)
                .Value = ws.Name
                For i = 0 To UBound(x)
                    .Cells(1, i + 2) = ws.Range(x(i))
                Next
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Thanks so much!

One last request on this: is there a way to have the code auto format the three columns to all have borders on all sides? Thanks again!

 

[Fuji]

One last request on this: is there a way to have the code auto format the three columns to all have borders on all sides? Thanks again!

try change to

Private Sub Worksheet_Activate()
    Dim x, i&, ws As Worksheet
    Application.ScreenUpdating = False
    With [a1]
        .CurrentRegion.Borders.LineStyle = xlNone
        .CurrentRegion.ClearContents
        x = Array("A1", "C1", "G2") '<--- Add/Remove/Change as you wish
        .Value = "Sheet Name"
        .Cells(1, 2).Resize(, UBound(x) + 1) = x
        For Each ws In Worksheets
            If ws.Name <> Me.Name Then
                With Me.Range("a" & Rows.Count).End(xlUp)(2)
                    .Value = ws.Name
                    For i = 0 To UBound(x)
                        .Cells(1, i + 2) = ws.Range(x(i))
                    Next
                End With
            End If
        Next
        .CurrentRegion.Borders.Weight = 2
        .CurrentRegion.Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

 

[Ryusui]

try change to

Private Sub Worksheet_Activate()
    Dim x, i&, ws As Worksheet
    Application.ScreenUpdating = False
    With [a1]
        .CurrentRegion.Borders.LineStyle = xlNone
        .CurrentRegion.ClearContents
        x = Array("A1", "C1", "G2") '<--- Add/Remove/Change as you wish
        .Value = "Sheet Name"
        .Cells(1, 2).Resize(, UBound(x) + 1) = x
        For Each ws In Worksheets
            If ws.Name <> Me.Name Then
                With Me.Range("a" & Rows.Count).End(xlUp)(2)
                    .Value = ws.Name
                    For i = 0 To UBound(x)
                        .Cells(1, i + 2) = ws.Range(x(i))
                    Next
                End With
            End If
        Next
        .CurrentRegion.Borders.Weight = 2
        .CurrentRegion.Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

You're amazing! Thank you so much for your help!

 

[Ryusui]

try change to

Private Sub Worksheet_Activate()
    Dim x, i&, ws As Worksheet
    Application.ScreenUpdating = False
    With [a1]
        .CurrentRegion.Borders.LineStyle = xlNone
        .CurrentRegion.ClearContents
        x = Array("A1", "C1", "G2") '<--- Add/Remove/Change as you wish
        .Value = "Sheet Name"
        .Cells(1, 2).Resize(, UBound(x) + 1) = x
        For Each ws In Worksheets
            If ws.Name <> Me.Name Then
                With Me.Range("a" & Rows.Count).End(xlUp)(2)
                    .Value = ws.Name
                    For i = 0 To UBound(x)
                        .Cells(1, i + 2) = ws.Range(x(i))
                    Next
                End With
            End If
        Next
        .CurrentRegion.Borders.Weight = 2
        .CurrentRegion.Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

Actually, I did have two more questions on this, if you're so inclined to assist with those as well.

First, is there a way to omit two specific sheets - named "Values" and "Report" from the "Summary"?

And second - is there a way to have the first row of three cells always be the words "VENDOR", "PO#", and "AWB#" in bold?

Thank you again so much!

 

[Fuji]

Try change to

Private Sub Worksheet_Activate()
    Dim x, i&, ws As Worksheet
    Application.ScreenUpdating = False
    With [a1]
        .CurrentRegion.Borders.LineStyle = xlNone
        .CurrentRegion.ClearContents
        x = Array("A1", "C1", "G2") '<--- Add/Remove/Change as you wish
        .Value = "Sheet Name"
        .Cells(1, 2).Resize(, UBound(x) + 1) = [{"VEDOR","PO#","AWB#"}]
        For Each ws In Worksheets
            Select Case UCase$(ws.Name)
                Case "VALUES", "REPORT", UCase$(Me.Name)  '<--- sheet name(s) to be ignored
                Case Else
                    With Me.Range("a" & Rows.Count).End(xlUp)(2)
                        .Value = ws.Name
                        For i = 0 To UBound(x)
                            .Cells(1, i + 2) = ws.Range(x(i))
                        Next
                    End With
            End Select
        Next
        .CurrentRegion.Borders.Weight = 2
        .CurrentRegion.Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

 

[Ryusui]

Try change to

Private Sub Worksheet_Activate()
    Dim x, i&, ws As Worksheet
    Application.ScreenUpdating = False
    With [a1]
        .CurrentRegion.Borders.LineStyle = xlNone
        .CurrentRegion.ClearContents
        x = Array("A1", "C1", "G2") '<--- Add/Remove/Change as you wish
        .Value = "Sheet Name"
        .Cells(1, 2).Resize(, UBound(x) + 1) = [{"VEDOR","PO#","AWB#"}]
        For Each ws In Worksheets
            Select Case UCase$(ws.Name)
                Case "VALUES", "REPORT", UCase$(Me.Name)  '<--- sheet name(s) to be ignored
                Case Else
                    With Me.Range("a" & Rows.Count).End(xlUp)(2)
                        .Value = ws.Name
                        For i = 0 To UBound(x)
                            .Cells(1, i + 2) = ws.Range(x(i))
                        Next
                    End With
            End Select
        Next
        .CurrentRegion.Borders.Weight = 2
        .CurrentRegion.Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

This is working great! Thank you!