Excel VBA - 循环工作表，复制单元格，参考第一个工作表

Question

I am setting up a planning workbook where my company would have individual sheets (all set the same way) planning individual projects. These sheets would have certain cells (the same on each sheet) that would then be referenced by the main master schedule, a compilation of the high points of the subproject schedules. Is this possible? I am quite new at VBA coding so please be nice:)

I currently have a bit of code written to copy and paste into the last empty cell in Column B on the target sheet, but this code doesn't work anyway (havent figured out why yet). But ideally I would like the cells to be referenced, not copy+pasted, to avoid miscommunication between sheets when things change. Code pasted below for reference, would also appreciate help fixing this in addition to the other referencing issue.

Sub LoopAndInsert()

Dim ws As Worksheet
Dim target As Worksheet
    Set target = Worksheets("Global Schedule Gantt") 'sheet we're copying to
    
    For Each ws In ThisWorkbook.Worksheets  'loop through all worksheets
    
     If ws.Name <> target.Name Then   'if not the target sheet then...
         'copy range into the next blank row in column C
         ws.Range("CopyToGlobal").Copy target.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
     End If
     
Next ws
End Sub

Answer 1

See if this is what you're after. I'm assuming you want the cells in the master sheet to simply reference (eg =Sheet1!$A$1 ) rather than just have the value.

EDIT: Changed code upon new information.

Sub LoopAndInsert()

Application.ScreenUpdating = False 'I would set these 2 off with this.
Application.Calculation = xlCalculationManual

Dim ws As Worksheet, target As Worksheet
Dim lrow As Long, lrowMaster As Long, i As Long, j As Long

Set target = Worksheets("Global Schedule Gantt") 'sheet we're copying to
lrowMaster = target.Range("B" & Rows.Count).End(xlUp).Row
    
For Each ws In ThisWorkbook.Worksheets  'loop through all worksheets
    If ws.Name <> target.Name Then   'if not the target sheet then...
        For i = 14 To 42
            Select Case i
                Case 14, 15, 16, 18, 23, 25, 26, 29, 31, 32, 33, 35, 36, 41, 42
                lrowMaster = lrowMaster + 1 'Move down to next available row
                For j = 3 To 9
                    target.Cells(lrowMaster, j - 1).Formula = "='" & ws.Name & "'!" & ws.Cells(i, j).Address
                Next j
            End Select
        Next i
    End If
Next ws

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Answer 2

Copy Cell References of a Non-Contiguous (Multi-Area) Range

• Adjust the values in the constants section.

The Code

Option Explicit

Sub LoopAndInsert()
    
    Const dstName As String = "Global Schedule Gantt"
    Const dstCol As String = "B"
    Const srcRange As String = "CopyToGlobal"
    ' Or:
    'Const srcRange as String _
        = "C14:I16,C18:I18,C23:I23,C25:I26,C29:I29,C31:I33,C35:I36,C41:I42"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim cel As Range
    With wb.Worksheets(dstName)
        Set cel = .Cells(.Rows.Count, dstCol).End(xlUp).Offset(1)
    End With
    
    Dim src As Worksheet
    Dim sRng As Range
    Dim dRng As Range
    For Each src In wb.Worksheets
        If src.Name <> dstName Then
            For Each sRng In src.Range(srcRange).Areas
                Set dRng = cel.Resize(sRng.Rows.Count, sRng.Columns.Count)
                    dRng.Formula _
                        = "='" & src.Name & "'!" & sRng.Cells(1).Address(0, 0)
                Set cel = cel.Offset(sRng.Rows.Count)
            Next sRng
        End If
    Next src

End Sub