Question

您好我正在尝试弄清楚当上面的行中有几个空格时，如何将一系列单元格粘贴到下一行。我的代码会一直覆盖它们。这是我的代码：

 Sub GetSheetstest()

   Dim Path As String
   Dim FileName As String
   Dim Sheet As Worksheet
   Dim pasteRow As Integer

   pasteRow = 2

  With Application
           .ScreenUpdating = False
        .EnableEvents = False
    End With

Windows("Data .xlsm").Activate

 With Sheets("Sheet1")
    .Rows(2 & ":" & .Rows.Count).Delete
End With


Path = "C:\blahz\"
FileName = Dir(Path & "*.xlsm")
Do While FileName <> ""
    Workbooks.Open FileName:=Path & FileName, ReadOnly:=True

    Sheets("Case Summary").Range("B2:B46").Copy
    Windows("Summary  Data v4.xlsm").Activate

    Range("A" & pasteRow).End(xlUp).Offset(1).Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True


     Workbooks(FileName).Activate

    Sheets("pear").Range("B2:B5").Copy
    Windows("Summary Data v4.xlsm").Activate

   Range("AT" & pasteRow).End(xlUp).Offset(1).Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True


         Workbooks(FileName).Activate

    Sheets(" apple").Range("B2:B18").Copy
    Windows("Summary  Data v4.xlsm").Activate

   Range("AX" & pasteRow).End(xlUp).Offset(1).Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True



       Workbooks(FileName).Activate

    Sheets("orange").Range("B2:B22").Copy
    Windows(" Summary data v4.xlsm").Activate

   Range("BO" & pasteRow).End(xlUp).Offset(1).Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True

      pasteRow = pasteRow + 1

    Workbooks(FileName).Close
    FileName = Dir()



Loop

With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

例如，对于工作表pear，大多数时候范围B2：B5是空的但是如果有一个值而不是去正确的行它会到达顶行，因为上面的所有行都是空白的。

Answer 1

未测试：

Sub GetSheetstest()

    Const F_PATH As String = "C:\blahz\"
    Dim FileName As String, shtDest As Worksheet, wb As Workbook, pasteRow As Long

    Set shtDest = Workbooks("Summary Data v4.xlsm").Sheets("Sheet1")
    shtDest.Rows(2 & ":" & shtDest.Rows.Count).Delete

    pasteRow = 2
    FileName = Dir(F_PATH & "*.xlsm")
    Do While FileName <> ""

        Set wb = Workbooks.Open(FileName:=F_PATH & FileName, ReadOnly:=True)

        CopyTranspose wb.Sheets("Case Summary").Range("B2:B46"), shtDest.Cells(pasteRow, "A")
        CopyTranspose wb.Sheets("pear").Range("B2:B5"), shtDest.Cells(pasteRow, "AT")
        CopyTranspose wb.Sheets("apple").Range("B2:B18"), shtDest.Cells(pasteRow, "AX")
        CopyTranspose wb.Sheets("orange").Range("B2:B22"), shtDest.Cells(pasteRow, "BO")

        pasteRow = pasteRow + 1

        wb.Close False
    Loop
End Sub

'utility: copy a range's values (transposed) to another location
Sub CopyTranspose(rngCopy As Range, rngDest As Range)
    rngDest.Resize(rngCopy.Columns.Count, rngCopy.Rows.Count).Value = _
               Application.Transpose(rngCopy.Value)
End Sub

当上面的行有空白时，vba会粘贴下一行的范围

1 个答案: