Excel宏將格式不正確的數據複製到表中

Question

我一直負責從奇怪/格式不正確的Excel表格中提取數據。有太多的數據需要手動複製，所以我試圖使用宏。我對VBA不是很熟練，但我知道一點（可能剛好足以打破某些東西:)）。

我現在只在一張紙上工作，但有幾張紙，都是用相同的方式格式化的。以下是源數據的片段： 我突出顯示了我需要複製的單元格。其餘數據不重要，不需要提取。

正如你可以看到，源數據未格式化爲傳統的行和列，至少可以這樣說。

我正在將這些數據複製到我在新工作表中設置的表中。

****編輯：****我更新了我的代碼。我意識到數據被格式化爲數據中的行之間有相同數量的空間，我需要的是14。我現在有一個Do While Loop，每次將行索引增加14以移至下一個記錄。

此代碼有效，但我正在討論這個正確的方式？我將需要重複這個過程約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。

這不是一個非常技術性的答案，我知道，但它看起來像你非常接近，我不想在評論中輸入所有這些。