使用空单元格作为参数复制单元格区域-> PasteSpecial新工作表

Question

My data is all in one column and grows downward. There are only a few rows of data and then blank spaces ( the # of blank spaces varies ).

I'm trying to select each group of data and transpose it automatically onto the next sheet in the next available row, and continue until there is no more data in the column.

Please forgive my ignorance of the below, I pieced it together from many hours of googling and searching this site.

Here is what I have so far, and it kind of works… but I think I need another integer to be defined, so I can get a range to copy, like

Sheets("Sheet1").Range(A & I “:” A & X ).Copy

Then, a similair operation to paste:

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

Complete Macro I'm working with:

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

The code would to be like this.

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 2

Here I define a Source range and then using the Range's SpecialCells method I break the Source into Areas. Next I iterate over the Areas of the Source range and transpose them to the next empty cell on 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 3

Function to skip blank cells will be useful in your case:

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

It takes cell as parameter, and looks for next non-empty cell. If given cell is not empty, it will return its row, if it is empty, the function will return row of next non-empty cell. Using that function, we can write the following:

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

This subroutine takes first block of data, puts it in C column, then skips blanks until next block of data and puts it in D column, etc. Instead of going to another column, you can go as well to another sheet.