パラメータとして空のセルを使用してセルの範囲をコピー - > PasteSpecial新しいワークシート

Question

私のデータはすべて1列にあり、下に向かっています。ほんのわずかの行のデータと空白スペース（空白スペースの＃が変わります）があります。

データの各グループを選択し、次の使用可能な行の次のシートに自動的に転置し、列にデータがなくなるまで続行しようとしています。

私の知らないことを許してください、私は数時間のグーグルグーグルと一緒にこのサイトを検索しました。ここで

は、私がこれまで持っているものであり、それは一種の作品...しかし、私は私が定義する別の整数が必要だと思うので、私はコピーする範囲を得ることができ、その後

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

、similairのような

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

私が働いている完全なマクロ：コードはlで

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範囲の領域を繰り返し、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

うを貼り付ける操作私はこれ。

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列にそれを置く代わりに別の列に行くと、別のシートにも行くことができます。