Excel形式のデータをテーブルにコピーしていない

Question

私は、Excelシートからデータを抜粋することを妙に/不適切にフォーマットしています。手動でコピーするにはあまりにも多くのデータがあるので、私はマクロを使用しようとしています。私はVBAにはあまり熟練していませんが、私はちょっとだけ知っています。

私はちょうど1枚のシートで作業していますが、いくつかのシートがあり、すべて同じようにフォーマットされています。ここに、ソースデータのようなスニペットがあります： 私はコピーが必要なセルを強調表示しました。残りのデータは重要ではなく、抽出する必要はありません。

あなたが見ることができるように、ソースデータは、控えめに言っても、伝統的な行と列としてフォーマットされていません。

私は新しいシートに設定したテーブルにこのデータをコピーしています。

****編集：****私のコードを更新しました。私は、データが必要なデータの行間に同じ量のスペースがあるところにフォーマットされていることに気付きました。正確には14です。私は今、次のレコードに移動するたびに行インデックスを14ずつインクリメントするDo While Loopを持っています。

このコードは機能しますが、これについて正しい方法はありますか？このプロセスを約50枚繰り返す必要があります。そのうちのいくつかは1000以上のレコードを持っています。

Sub CopyData() 

Dim SourceSheet As Worksheet 
Dim DestSheet As Worksheet 
Dim DestRow As Long 
Dim i As Integer 
i = 0 

Set SourceSheet = Sheets("Sheet1") 
Set DestSheet = Sheets("Data") 

Do While i < 100 
    DestRow = DestSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1 
    SourceSheet.Cells(2 + i, 1).Copy 
    DestSheet.Range("A" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
    Application.CutCopyMode = False 

    SourceSheet.Cells(2 + i, 2).Copy 
    DestSheet.Range("D" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
    Application.CutCopyMode = False 

    SourceSheet.Cells(3 + i, 2).Copy 
    DestSheet.Range("E" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
    Application.CutCopyMode = False 

    SourceSheet.Cells(4 + i, 2).Copy 
    DestSheet.Range("F" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
    Application.CutCopyMode = False 

    SourceSheet.Cells(2 + i, 7).Copy 
    DestSheet.Range("C" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
    Application.CutCopyMode = False 

    SourceSheet.Cells(5 + i, 7).Copy 
    DestSheet.Range("G" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
    Application.CutCopyMode = False 

    SourceSheet.Cells(14 + i, 2).Copy 
    DestSheet.Range("B" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
    Application.CutCopyMode = False 

    i = i + 14 
Loop 

End Sub 

Answer 1

私はを投稿しています。最終コードここでは、将来誰かを助けることができる場合に備えて来ました。データに等しい間隔があることが分かったら、思ったほど難しくないことが判明しました。お返事ありがとう@Doug Glancy Exit Doのご使用についてアドバイスをいただきました。

これは完璧な解決策ではありません。何らかのエラー処理/チェックを追加する必要があります。コードを改善する方法やこれを達成するためのさまざまな方法についてアドバイスをいただきたいと思います。

Sub CopyData() 

Dim DestSheet As Worksheet 
Dim DestRow As Long 
Dim i As Integer 


Set DestSheet = Sheets("Data") 

'Loop through all worksheets in the workbook 
For Each Worksheet In ActiveWorkbook.Worksheets 

'Reset counter variable for each worksheet 
i = 0 

    'Check to make sure we are not on the destination sheet 
    If Worksheet.Name <> DestSheet.Name Then 

     'Loop through all rows in the sheet 
     Do While i < Worksheet.Rows.Count 

      'Check the contents of the first row in the record to ensure that it contains data 
      If Worksheet.Cells(2 + i, 1) <> "" Then 

       'Find the next empty row in the destination sheet to copy to 
       DestRow = DestSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1 

       'Copy and paste data, using paste special because of the formatting and formulas in the source 
       Worksheet.Cells(2 + i, 1).Copy 
       DestSheet.Range("A" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
        :=False, Transpose:=False 
       Application.CutCopyMode = False 

       Worksheet.Cells(2 + i, 2).Copy 
       DestSheet.Range("D" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
        :=False, Transpose:=False 
       Application.CutCopyMode = False 

       Worksheet.Cells(3 + i, 2).Copy 
       DestSheet.Range("E" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
        :=False, Transpose:=False 
       Application.CutCopyMode = False 

       Worksheet.Cells(4 + i, 2).Copy 
       DestSheet.Range("F" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
        :=False, Transpose:=False 
       Application.CutCopyMode = False 

       Worksheet.Cells(2 + i, 7).Copy 
       DestSheet.Range("C" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
        :=False, Transpose:=False 
       Application.CutCopyMode = False 

       Worksheet.Cells(5 + i, 7).Copy 
       DestSheet.Range("G" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
        :=False, Transpose:=False 
       Application.CutCopyMode = False 

       Worksheet.Cells(14 + i, 2).Copy 
       DestSheet.Range("B" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
        :=False, Transpose:=False 
       Application.CutCopyMode = False 

       'Add 14 to counter, since the rows are equally spaced by 14 
       i = i + 14 

      Else 

      'If the first row contains no data, then exit the loop 
       Exit Do 

      End If 
     Loop 

    End If 

Next 

End Sub 

Answer 2

はい、あなたがしていることは良いと思います。あなたはパターンを理解し、それをどのように増やすのかを理解しました。シートの終わりに達したときに何らかのチェックを追加したいと思うかもしれません。最も簡単なのは、Doの後の最初の行で空白をテストし、そのループをExit Doで終了することです。外側のループはFor each ws in wb.Worksheetsです。

これはあまり技術的な答えではありませんが、あなたが非常に近いと思われ、コメントにすべて入力する必要はありませんでした。