Actively Copy Cells From Multiple Worksheets

Ryusui

New Member
Joined
Apr 15, 2006
Messages
29
Office Version
  1. 365
Platform
  1. Windows
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:


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!
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
VBA solution :


VBA Code:
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
 
Upvote 0
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.
Code:
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
 
Upvote 0
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.
Code:
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!
 
Upvote 0
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
Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,875
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