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

尝试......你实际上需要两个行值，一个用于数据，一个用于输出：

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