使用空單元格作爲參數複製一系列單元格 - > PasteSpecial新工作表

Question

我的數據全部在一列中並向下增長。只有幾行數據，然後是空格（空格的數量有所不同）。

我試圖選擇每組數據並將其自動轉置到下一個可用行中的下一個工作表，並繼續，直到列中沒有更多數據。

請原諒我對下面的無知，我把它拼湊在一起搜索並搜索這個網站。

這裏是我到目前爲止，這樣的作品...但我想我需要定義另一個整數，這樣我就可以得到一個範圍內進行復制，像

Sheets("Sheet1").Range(A & I 「:」 A & X).Copy 

然後，similair操作粘貼：

Sheets("Sheet2").End(xlUp).Row.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:= _ 
False, Transpose:=True 

完全微距我的工作：

Sub PadOut() 
Application.ScreenUpdating = False 

Dim i As Integer, j As Integer 
j = 1 
    'loops from 1 to the last filled cell in column 1 or "A" 
    For i = 1 To Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).row 
     'checks if the cell has anything in it 
     If IsEmpty(Sheets("Sheet1").Range("A" & i)) = False Then 
      'this is where the copying and pasting happens (well basically) 
      Sheets("Sheet1").Range(A & i).copy 
      Sheets("Sheet2").End(xlUp).Row).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:= _ 
      False, Transpose:=True 
      j = j + 1 
     End If 
    Next i 

    Application.ScreenUpdating = True 

End Sub 

Answer 1

這裏我定義一個Source範圍，然後使用Range的SpecialCells方法將Source分解爲區域。接下來我遍歷源範圍的區域並將它們轉置到Sheet2上的下一個空單元格。

Sub PadOut() 
    Application.ScreenUpdating = False 
    Dim Source As Range, Target As Range 
    Dim i As Long 

    With Sheets("Sheet1") 
     On Error Resume Next 
     Set Source = .Range("A1", .Range("A" & Rows.Count).End(xlUp)) 
     Set Source = Source.SpecialCells(xlCellTypeConstants) 
     On Error GoTo 0 
    End With 

    If Not Source Is Nothing Then 
     With Sheets("Sheet2") 

      For i = 1 To Source.Areas.Count 
       Source.Areas(i).Copy 
       Set Target = .Range("A" & Rows.Count).End(xlUp) 

       If Target.Value = "" Then 
        Target.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True 
       Else 
        Target.Offset(1).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True 
       End If 
      Next 

     End With 
    End If 
    Application.ScreenUpdating = True 

End Sub 

Answer 2

代碼將爲L這個。

Sub PadOut() 
Application.ScreenUpdating = False 

Dim i As Long 
Dim n As Long 
n = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 

    'loops from 1 to the last filled cell in column 1 or "A" 

    For i = 1 To n 
     'checks if the cell has anything in it 
     If IsEmpty(Sheets("Sheet1").Range("A" & i)) = False Then 
      'this is where the copying and pasting happens (well basically) 
      Sheets("Sheet1").Range("A" & i).Copy Sheets("Sheet2").Range("a" & Rows.Count).End(xlUp)(2) 
     End If 
    Next i 

    Application.ScreenUpdating = True 

End Sub 

Answer 3

功能跳過空白單元格會在你的情況下非常有用：

Function SkipBlanks(start As Range) As Long 
Dim r, c As Long 
r = start.Row 
c = start.Column 
'we make sure, that we won't exceed the number of rows 
Do While IsEmpty(Cells(r, c)) And r < Rows.Count 
    r = r + 1 
Loop 

SkipBlanks = r 

End Function 

它採用電池作爲參數，並尋找下一個非空單元格。如果給定的單元格不爲空，它將返回它的行，如果它是空的，函數將返回下一個非空單元格的行。使用該功能，我們可以寫出如下：

Sub s() 
Dim startingRow, i, j As Long 
j = 3 
i = 1 

'we will through all rows 
Do While i < Rows.Count 
    'we skip blanks 
    startingRow = SkipBlanks(Cells(i, 1)) 
    i = startingRow 

    Do While Not IsEmpty(Cells(i, 1)) 
     Cells(i - startingRow + 1, j).Value = Cells(i, 1).Value 
     i = i + 1 
    Loop 

    'we move to next column (here you can place code, which will choose next sheet to use 
    j = j + 1 

Loop 
End Sub 

這個子程序需要數據的第一個塊，把在C柱，然後跳過空白，直到數據的下一個塊，並將其放在d柱等相反去另一列，你可以去另一張表。