Excel VBA - Loop к следующей доступной пустой ячейке

Question

Я пытаюсь написать небольшой раздел кода, чтобы создать новый лист и вставить значения из таблицы в исходном листе, начиная со строки 2, столбец 1 через столбец 4. После этого достигает конца, мне нужно, чтобы он перешел в следующую строку и начал все заново.

Проблема заключается в том, что приведенный ниже код возвращается к строке 1 нового листа и данные переопределяются. Есть ли простой способ, чтобы мой цикл начинался с первой пустой строки вниз?

[2

Sub SAX() 

Dim wsSource As Excel.Worksheet, wsData As Excel.Worksheet 
Dim r As Long, c As Long 

Set wsData = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) 
wsData.Name = "Data" 
Set wsSource = ThisWorkbook.Worksheets("Header") 

Application.DisplayAlerts = False 

r = 2 
Do Until Len(Trim(wsSource.Cells(r, 1).Value)) = 0 
    For c = 1 To 4 
     wsData.Cells(c * 1, 1).Value = wsSource.Cells(r, c).Value 
    Next c 

    ThisWorkbook.Activate 
    r = r + 1 
Loop 

Application.DisplayAlerts = True 

End Sub 

Answer 1

что вы хотите это, предполагая (со скриншота), что вы работаете со структурированной таблицей ListObject:

Sub SAX() 

Dim wsSource As Excel.Worksheet, wsData As Excel.Worksheet 
Dim i as Long 
Dim tbl As ListObject 
Dim vals As Variant 

With ThisWorkbook 
    Set wsData = Sheets.Add(After:=.Sheets(.Sheets.Count)) 
    Set wsSource = .Worksheets("Header") 
End With 
wsData.Name = "Data" 

'## Get a handle on the Table object 
Set tbl = wsSource.ListObjects(1) 'Modify if needed 

Application.DisplayAlerts = False 

i = 1 'which row we start putting data on wsData 
'## Iterate each row of data in the Table 
For Each rng In tbl.DataBodyRange.Rows 
    '## Dump this row's values in to an array, and transpose it 
    vals = Application.Transpose(rng.Value) 
    '## Put the array's values in an appropriately sized range on the wsData sheet: 
    wsData.Cells(i, 1).Resize(UBound(vals)).Value = vals 
    '## Increment the destination row number: 
    i = i + UBound(vals) 
Next 

Application.DisplayAlerts = True 

End Sub 

Здесь мы переносим rng.Value так, чтобы мы могли отбросить его в столбце. Мы сохраняем это в массиве vals. Затем мы используем массив vals для определения размера диапазона, в котором значения будут размещены на листе «Данные», а также используйте размер массива vals, чтобы увеличить нашу переменную i, которая сообщает нам, где положить следующий данные строки.

Или, может быть, еще проще:

For i = 1 to tbl.DataBodyRange.Cells.Count 
    wsData.Cells(i, 1).Value = tbl.DataBodyRange.Cells(i).Value 
Next 

Это работает, потому что диапазон индексируется строки/столбца, поэтому мы начинаем отсчет сотой # 1 в верхней/влево, а затем переносится на вторую строку и резюме подсчитывая, например, «индекс ячейки» в этом примере таблицы:

Это можно легко поместить в одну строку или столбец, только перебором Cells.Count!

Answer 2

Попробуйте это ... Вы на самом деле нужно два значения подряд, один для данных, один для вывода:

Sub SAX() 
Dim wsSource As Worksheet, wsData As Worksheet 
Dim lDataRow As Long, lCol As Long, lOut as Long 

Set wsData = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) 
wsData.Name = "Data" 
Set wsSource = ThisWorkbook.Worksheets("Header") 

Application.DisplayAlerts = False 
lDataRow = 2 
lOut = 1 
Do 
    For lCol = 1 To 4 
    wsData.Cells(lOut, 1) = wsSource.Cells(lDataRow, lCol) 
    Next lCol 
    lDataRow = lDataRow + 1 
    lOut = lOut + 1 
Loop Until Len(Trim(wsSource.Cells(lDataRow, 1))) = 0 

Application.DisplayAlerts = True 

End Sub 

Answer 3

Было бы более эффективно создавать массив и записывать все данные за один раз.

Sub SAX() 
    Dim Data, v 
    Dim x As Long, y As Long 

    With ThisWorkbook.Worksheets("Header") 
     With .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) 
      x = WorksheetFunction.RoundUp(.Cells.Count/4, 0) 
      ReDim Data(1 To x, 1 To 4) 
      x = 1 
      For Each v In .Cells 

       If y = 4 Then 
        x = x + 1 
        y = 1 
       Else 
        y = y + 1 
       End If 
       Data(x, y) = v 
      Next 
     End With 
    End With 

    With ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) 
     .Name = "Data" 
     .Range("A1:D1") = Array(1, 2, 3, 4) 
     .Range("A2:D2").Resize(UBound(Data, 1)).Value = Data 
    End With 

End Sub