Excel Macro копирует плохо отформатированные данные в таблицу

Question

Мне поручено извлечь данные из листа Excel, который странно/плохо отформатирован. Слишком много данных для ручной копирования, поэтому я пытаюсь использовать макрос. Я не очень разбираюсь в VBA, но знаю немного (возможно, достаточно, чтобы что-то сломать :)).

Я сейчас работаю только на 1 листе, но есть несколько листов, все они отформатированы одинаково. Вот фрагмент того, как выглядят исходные данные: Я выделил ячейки, которые мне нужно скопировать. Остальные данные не важны и их не нужно извлекать.

Как вы можете видеть, исходные данные не отформатирован как традиционные строки и столбцы, чтобы не сказать больше.

Я копирую эти данные в таблицу, которую я установил на новом листе.

**** Редактировать: **** Я обновил свой код. Я понял, что данные были отформатированы там, где есть те же промежутки между строками в данных, которые мне нужны, а точнее. У меня теперь есть цикл While While, который каждый раз увеличивает индекс Row на 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.

Это не очень технический ответ, который я знаю, но похоже, что вы очень близки, и я не хотел набирать все это в комментарии.