在所有当前和未来的工作表上复制相同的单元格并粘贴到工作表 1

Question

我有一个包含许多工作表的 Excel 工作簿。每张纸都标有月份和年份。即 2019 年 1 月，以此类推，第一张和第二张除外。

第一张纸被隐藏（在那里不做任何事情）。第二张表名为 Sales Chart（我想在其中粘贴数据）。其余的是月和年表。

我需要复制所有当前月份和年份表上的单元格 B5:B10，以及任何未来的表（将遵循月份和年份模式）。复制数据后，它应该水平粘贴（第一张表信息粘贴在 B31 行，第二张在 B32 行，依此类推）。

我正在使用我在网上找到的代码。它只复印一张。它复制公式，而不是公式结果。它垂直复制然后垂直粘贴，而不是垂直复制然后水平粘贴。

Sub MakeSummaryTable()
Dim ws As Worksheet

Application.ScreenUpdating = True
Sheets(1).Activate

For Each ws In Worksheets
    If ws.Name <> "Sales Chart" Then
        ws.Range("B5:B10").Copy
        ActiveSheet.Paste Range("B31").End(xlUp).Offset(1, 0)
    End If
Next ws

Application.ScreenUpdating = True

End Sub

我希望代码从所有当前工作表中复制单元格 B5:B10 上的结果并将其粘贴到工作表“销售图表”B31-G31（水平）并向下。

Answer 1

到目前为止我的解决方案，不确定检查月份是否正确的最佳方法。

Sub PasteValuesFromMonthSheets()
    Dim wsChart As Worksheet
    On Error Resume Next
    Set wsChart = ThisWorkbook.Worksheets("Sales Chart")
    On Error GoTo 0
    If wsChart Is Nothing Then
        MsgBox "Cannot find Worksheet 'Sales Chart'.", vbOKOnly
        Exit Sub
    End If

    Dim wsSrc As Worksheet
    Dim lngRowOffset As Long

    For Each wsSrc In ThisWorkbook.Worksheets
        Dim arrSrcName As Variant
        arrSrcName = Split(wsSrc.Name, " ")
        If UBound(arrSrcName) = 1 Then
            If IsNumeric(arrSrcName(1)) Then
                Dim intMonth, intYear As Integer
                intMonth = MonthInt(arrSrcName(0))
                intYear = arrSrcName(1)
                If intMonth > 0 And intYear Like "####" Then
                    wsSrc.Range(wsSrc.Cells(5, 2), wsSrc.Cells(10, 2)).Copy
                    wsChart.Cells(lngRowOffset + 31, 2).PasteSpecial xlPasteValues, , , True
                    lngRowOffset = lngRowOffset + 1
                End If
            End If
        End If
    Next wsSrc

    Set wsChart = Nothing
End Sub

Private Function MonthInt(ByVal MonthString As String) As Integer
    Select Case MonthString
        Case "January"
            MonthInt = 1
        Case "February"
            MonthInt = 2
        Case "March"
            MonthInt = 3
        Case "April"
            MonthInt = 4
        Case "May"
            MonthInt = 5
        Case "June"
            MonthInt = 6
        Case "July"
            MonthInt = 7
        Case "August"
            MonthInt = 8
        Case "September"
            MonthInt = 9
        Case "October"
            MonthInt = 10
        Case "November"
            MonthInt = 11
        Case "December"
            MonthInt = 12
        Case Else
            MonthInt = -1
    End Select
End Function

Answer 2

我不太确定你想在这里做什么：

Range("B31").End(xlUp).Offset(1, 0)

但你可以试试这个：

Sub MakeSummaryTable()
Dim ws As Worksheet

Application.ScreenUpdating = False
Sheets(1).Activate

For Each ws In Worksheets
    If ws.Name <> "Sales Chart" Then
        ws.Range("B5:B10").Copy
        If Range("B31").Value = "" Then
            Range("B31").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=True
        Else
            Range("B1048576").End(xlUp).Offset(1, 0).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=True
        End If
    End If
Next ws

Application.ScreenUpdating = True

End Sub

您添加“PasteSpecial”以使用此命令：

粘贴：=xlPasteValues

粘贴值而不是公式。

转置：=真

水平粘贴“垂直”数据，反之亦然。

最后，我用了这个：

Range("B1048576").End(xlUp).Offset(1, 0).Select

获取B列最后一行（假设B:G列最后一行和表尾之间没有其他数据）