通过从不同表格中提取数据在Excel中构build表格

我正试图通过从不同的工作表编号1,2,3,4中提取数据来在“效率”表上创build一个表格….我试图构build的表格有8列。 其中之一是date。 date只在纸张的一个单元格中，单元格G4，并且在每张纸上都是相同的点。 其他列来自B，C，D，E，F，O和Q列，从第9行开始向下。 列的大小可以改变，因为我们从表1到2到3等。我只想复制数据，没有别的。 有一些格式化到第20行，但不想复制固定数量的行，只是有数据。 当我将这些信息粘贴到“效率”表中时，我只需要数据，而不是格式。 我还希望date列的长度与其他数据点的长度以及从中获取的“date”表的长度相匹配。 我还希望在正在构build的表的第一行上有一个标题行，这些项目是“Date”和B，C，D，E，F，O和Q列的第8行（这是在每个“date”表单上相同，但在“效率”表单上只需要一次表格标题）。 任何人都可以帮助我意识到这一点吗？

谢谢

“

Sub DataTable() Dim wsTable As Worksheet Set wsTable = Worksheets("Efficiency") 'change as needed Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets Select Case ws.Name Case Is = "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15" With ws Dim rngData As Range Set rngData = Union(.Range("B:F"), .Range("O:O"), .Range("Q:Q")) Dim lRow As Long Dim rCheck As Range For Each rCheck In Intersect(rngData, .Rows(1)) If .Cells(.Rows.Count, rCheck.Column).End(xlUp).Row > lRow Then lRow = .Cells(.Rows.Count, rCheck.Column).End(xlUp).Row End If Next Dim dDate As Date dDate = .Range("G4").Value With wsTable .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(lRow, 1).Value = dDate ws.Range("B9:F" & lRow).Copy .Range("B" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial x1PasteValues ws.Range("O9:O" & lRow).Copy .Range("O" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial x1PasteValues ws.Range("Q9:O" & lRow).Copy .Range("Q" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial x1PasteValues End With End With End Select Next End Sub 

“

Answer 1

我想我明白你在做什么。 我想你正在努力使之变得更加困难。 以下是我使用一些循环创build的一些代码，以获取您想要的内容。 它将工作表的date复制到variables中。 接下来，我在第一列中放置了Date这个词，并将标题列B-I作了相应的调整。

 Dim rowDate As Date Sheets("Sheet1").Select rowDate = Cells(4, 7) Range("B9").Select ' Copy the header rows & make the word Date the first column Sheets("Efficiency").Range("A1") = "Date" Range("B8:F8").Copy Sheets("Efficiency").Range("B1").PasteSpecial xlPasteValues Range("O8").Copy Sheets("Efficiency").Range("H1").PasteSpecial xlPasteValues Range("Q8").Copy Sheets("Efficiency").Range("I1").PasteSpecial xlPasteValues ' Cycle throught the sheets and copy the data ' Each array item is the sheet name. Dim SheetArray(4) As String SheetArray(0) = "Sheet1" SheetArray(1) = "Sheet2" SheetArray(2) = "Sheet3" SheetArray(3) = "Sheet4" Dim EffRow As Integer ' Keep track of the correct row on the Efficiency sheet Dim EffCell As String ' Track the cell for effeciency EffRow = 2 For i = 0 To 3 Sheets(SheetArray(i)).Select rowDate = Cells(4, 7) Range("B9").Select ' Loop until a blank cell is reached Do While Not (IsEmpty(ActiveCell)) EffCell = "A" & EffRow Sheets("Efficiency").Range(EffCell) = rowDate Range(ActiveCell, Cells(ActiveCell.Row, ActiveCell.Column + 5)).Copy EffCell = "B" & EffRow Sheets("Efficiency").Range(EffCell).PasteSpecial xlPasteValues ActiveCell.Offset(0, 13).Copy EffCell = "H" & EffRow Sheets("Efficiency").Range(EffCell).PasteSpecial xlPasteValues EffCell = "I" & EffRow Sheets("Efficiency").Range(EffCell).PasteSpecial xlPasteValues EffRow = EffRow + 1 ActiveCell.Offset(1, 0).Activate Loop Next i 

结束小组

希望这会使你朝正确的方向发展。