Excel VBA - 循环到下一个可用的空白单元格

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

试试这个……你实际上需要两个 Row 值，一个用于数据，一个用于输出：

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