Excel宏/如何编写宏以将工作簿中的行复制/粘贴200张到表

2 回答

• 0

  未经测试：

  Dim r As Long, sht As Worksheet
  
  r = 4
  
  For Each sht In Workbooks("Peak.xlsm").Worksheets
      sht.Range("O6:O150").Copy
      Workbooks("Table.xlsm").Sheets(1).Cells(r, "E").PasteSpecial Transpose:=True
      r = r + 1
  Next sht
  

  回复于 2024-04-27T21:46:32+08:00
• 0

  由于OP需要维护按父表名称排序的粘贴数据，因此下面是两个可能的代码：

  ---

  temporary helper column

  这种方法

  • 在列“E”之前插入一个（临时）列，用于存储工作表名称，而相应的数据从下一列写入到rigthwards .

  • 对（临时）列“E”中的工作表名称的粘贴范围进行排序

  • 删除临时列

  Option Explicit
  
  Sub Main()
      Dim iSht As Long
      Dim sht As Worksheet
  
      With Workbooks("Table.xlsm").Worksheets(1)
          .Columns("E").Insert '<--| insert temporary helper column
          For Each sht In Workbooks("Peak.xlsm").Worksheets '<--| loop through sheets
              sht.Range("O6:O150").Copy
              .Cells(4 + iSht, "E") = sht.Name '<--| write sheet name in temporary helper column
              .Cells(4 + iSht, "F").PasteSpecial Transpose:=True '<--| write data from the next colum rightwards
              iSht = iSht + 1
          Next sht
  
          With .Cells(4, "E").Resize(iSht, 146) '<--| consider temporary helper column cells containing sheet names
              .Sort key1:=.Cells(1, 1), order1:=xlAscending '<--| sort them
              .EntireColumn.Delete '<--| remove temporary helper column
          End With
      End With
  End Sub
  

  ---

  array with ordered sheet names

  这需要将它们写在临时表格中（在 ThisWorkbook 中），对它们进行排序并将它们读回来（参见 Function GetSortedWsNames() ）

  Sub Main2()
      Dim i As Long: i = 4
      Dim wb As Workbook
      Dim el As Variant
  
      Set wb = Workbooks("Peak.xlsm")
      With Workbooks("Table.xlsm").Worksheets(1)
         For Each el In GetSortedWsNames(wb)
             wb.Worksheets(el).Range("O6:O150").Copy
             .Cells(i, "E").PasteSpecial Transpose:=True
             i = i + 1
         Next el
      End With
  End Sub
  
  
  Function GetSortedWsNames(wb As Workbook) As Variant
      Dim ws As Worksheet
      Dim iSht As Long
  
      Set ws = ThisWorkbook.Worksheets.Add
      With wb
          For iSht = 1 To .Worksheets.Count
             ws.Cells(iSht, 1) = .Worksheets(iSht).Name
          Next iSht
      End With
  
      With ws.Cells(1, 1).Resize(iSht - 1)
          .Sort key1:=ws.Cells(1, 1), order1:=xlAscending
          GetSortedWsNames = Application.Transpose(.Cells)
      End With
  
      Application.DisplayAlerts = False
      ws.Delete
      Application.DisplayAlerts = True
  End Function
  

  回复于 2024-04-27T21:46:32+08:00