Question

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

由于

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

我想我明白你要做什么。我认为你试图让它比必要的要困难一些。这是我使用一些循环创建的一些代码，以获得您想要的内容。它将工作表的日期复制到变量中。接下来，我将单词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

End Sub

希望这会引导你朝着正确的方向前进。

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

1 个答案: