如何自动将特定范围的单元格从30张复制到1张。

Question

我每月每天有30张。在每个列中都有相同的列具有不同的数据，例如在A1：A30范围内。所以我的任务是从所有工作表中复制此范围，并将其复制到不同相邻列中的一个主工作表中，例如。 A1：A30，B1：B30，C1：C30等等。

Answer 1

下载并安装此AddIn。

https://www.rondebruin.nl/win/addins/rdbmerge.htm

这将为您完成工作，以及您正在做的许多其他变体。

Answer 2

这是复制范围的通用代码：

Sub Copy_ranges()

   Dim NS As Worksheet

   Application.ScreenUpdating = False
   Application.EnableEvents = False

   Set NS = Sheets.Add

   i = 1
   refRange = "A1:D10"

   For Each sht In Worksheets
      If (sht.Name <> NS.Name) Then
         Set SheetRange = sht.Range(Right(refRange, Len(refRange) - InStr(refRange, "!")))
         SheetRange.Copy
         NS.Cells(i, 1).Value = sht.Name
         NS.Cells(i, 2).PasteSpecial xlPasteValues
         i = i + SheetRange.Rows.Count
      End If
   Next sht
   Application.ScreenUpdating = True
   Application.EnableEvents = True

End Sub

您可以将refRange修改为您的范围和粘贴周期以满足您的需求：

Sub Copy_ranges()

    Dim NS As Worksheet

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Set NS = Sheets.Add

    i = 1
    refRange = "A1:A10"

    For Each sht In Worksheets
        If (sht.Name <> NS.Name) Then
          Set SheetRange = sht.Range(Right(refRange, Len(refRange) - InStr(refRange, "!")))
          SheetRange.Copy
          NS.Cells(1, i).Value = sht.Name
          NS.Cells(2, i).PasteSpecial xlPasteValues
          i = i + SheetRange.Columns.Count
        End If
    Next sht

    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub