Excel-Makro, das schlecht formatierte Daten in Tabelle

Question

kopiert Ich bin mit dem Extrahieren von Daten aus einem Excel-Blatt beauftragt worden, das seltsam/schlecht formatiert ist. Es gibt viel zu viele Daten, um manuell zu kopieren, also versuche ich ein Makro zu verwenden. Ich bin nicht sehr geschickt mit VBA, aber ich weiß ein wenig (wahrscheinlich gerade genug, um etwas zu brechen :)).

Ich arbeite gerade an 1 Blatt, aber es gibt mehrere Blätter, alle auf die gleiche Weise formatiert. Hier ist ein Ausschnitt davon, wie die Quelldaten aussehen: Ich habe die Zellen markiert, die ich kopieren muss. Der Rest der Daten ist nicht wichtig und muss nicht extrahiert werden.

Wie Sie sehen können, werden die Quelldaten nicht als traditionelle Zeilen und Spalten formatiert ist, gelinde gesagt.

Ich kopiere diese Daten in eine Tabelle, die ich in einem neuen Blatt eingerichtet habe.

**** Bearbeiten: **** Ich habe meinen Code aktualisiert. Ich erkannte, dass die Daten so formatiert waren, dass zwischen den Zeilen in den Daten, die ich benötige, genau die gleiche Anzahl von Leerzeichen vorhanden war, 14 um genau zu sein. Ich habe jetzt eine Do While-Schleife, die den Zeilenindex jedes Mal um 14 erhöht, um zum nächsten Datensatz zu gelangen.

Dieser Code funktioniert, aber gehe ich den richtigen Weg ??? Ich muss diesen Vorgang für etwa 50 Blatt wiederholen, von denen einige 1000 oder mehr Datensätze haben.

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

Ich poste die fast endgültigen Code Ich kam hier für den Fall, dass es jemand in der Zukunft helfen kann. Es stellte sich heraus, dass es nicht ganz so schwer war, wie ich dachte, nachdem ich festgestellt hatte, dass die Daten in gleichen Abständen waren. Danke @Doug Glancy für Ihren Rat zur Verwendung von Exit Do.

Ich bin sicher, das ist bei weitem keine perfekte Lösung. Müssen einige Fehlerbehandlung/Überprüfung hinzufügen. Ich würde mich über jeden Hinweis freuen, wie der Code verbessert werden könnte, oder über andere Möglichkeiten, dies zu erreichen.

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

Ja, ich denke, was Sie tun, ist gut. Sie haben das Muster herausgefunden und wie Sie es erhöhen können. Sie möchten wahrscheinlich eine Art von Überprüfung hinzufügen, wenn Sie das Ende eines Blattes erreicht haben - das einfachste wäre, nach einem Leerzeichen in der ersten Zeile nach dem Do zu testen und diese Schleife mit einem Exit Do zu verlassen, das Sie in einen äußere Schleife wie For each ws in wb.Worksheets.

Das ist keine sehr technische Antwort, die ich weiß, aber es scheint, als ob Sie sehr nah sind und ich wollte das alles nicht in einen Kommentar eingeben.