Excel VBA копирует строки между пробелами - PullRequest
Новая
       5

Excel VBA копирует строки между пробелами

1 голос
/ 06 мая 2020

У меня нет опыта работы с VBA, и я пытаюсь понять, смогу ли я заставить его запускать что-то для меня в Excel.

У меня есть набор данных сборок с частями внизу, система может потяните его только в одном полном наборе данных от верхней сборки до нижней (326 сборок).

Мне нужно решение, которое копирует строки сборок на новый лист, поэтому у меня есть вкладка для каждого сборки.

Dataset example

Следующий код, который я взял: 

Sub Star123()
   Dim rownum As Long
   Dim colnum As Long
   Dim startrow As Long
   Dim endrow As Long
   Dim lastrow As Long
   rownum = 1
   colnum = 1
   lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
   With ActiveWorkbook.Worksheets("Sheet1").Range("a1:a" & lastrow)


   For rownum = 1 To lastrow
    Do
       If .Cells(rownum, 1).Value = "Start" Then
          startrow = rownum
       End If

       rownum = rownum + 1


   If (rownum > lastrow) Then Exit For

   Loop Until .Cells(rownum, 1).Value = "End"
   endrow = rownum
   rownum = rownum + 1


   Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy

   Set newSht = Sheets.Add
   Range("A1").Select
   ActiveSheet.Paste


   Next rownum
End With
End Sub

Однако это просто запускает набор данных wole, мне нужно понять, как l oop можно разделить на новые листы.

1 Ответ

0 голосов
/ 07 мая 2020

Попробуйте это. Я добавил несколько комментариев.

Основная проблема с вашим кодом заключалась только в указанной единственной строке, которая пропускала следующий «Старт».

Код можно было бы упростить, если бы каждый Начало "всегда происходит сразу после" Конец ". 

Sub Star123()

Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
Dim newSht As Worksheet

rownum = 1
colnum = 1
lastrow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row 'better than hardcoding 65336 which won't work for recent versions of xl anyway

With ActiveWorkbook.Worksheets("Sheet1").Range("a1:a" & lastrow)
    For rownum = 1 To lastrow
        Do
            If .Cells(rownum, 1).Value = "Start" Then
                startrow = rownum
            End If
            rownum = rownum + 1
            If (rownum > lastrow) Then Exit For
        Loop Until .Cells(rownum, 1).Value = "End"
        endrow = rownum
        'rownum = rownum + 1 'just needed to comment out this line as it was skipping the next Start
        Set newSht = Sheets.Add
        Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy newSht.Range("A1") 'reference sheet directly without selecting or activating
    Next rownum
End With

End Sub
...