如何使用for-next循环声明变量

Question

下面的代码非常好。

Sub Macro1()

'Convert plain excel data to Excel Table. (Excel workbook consist of 3 sheets)
For i = 1 To 3
    Worksheets(i).Select
    Worksheets(i).ListObjects.Add SourceType:=xlSrcRange, Source:=Range("A1:C50"), XlListObjectHasHeaders:=xlYes
Next i

'Load data from Excel Table to Variant
Dim Variant1 As Variant
Variant1 = Worksheets(1).ListObjects(1).DataBodyRange

Dim Variant2 As Variant
Variant2 = Worksheets(2).ListObjects(1).DataBodyRange

Dim Variant3 As Variant
Variant3 = Worksheets(3).ListObjects(1).DataBodyRange

'Loop through each item in Third Column of Table
Dim x1 As Long
For x1 = LBound(Variant1) To UBound(Variant1)
    Debug.Print Variant1(x1, 3)
Next x1

Dim x2 As Long
For x2 = LBound(Variant2) To UBound(Variant2)
    Debug.Print Variant2(x2, 3)
Next x2

Dim x3 As Long
For x3 = LBound(Variant3) To UBound(Variant3)
    Debug.Print Variant3(x3, 3)
Next x3

End Sub

我想缩短上面的代码。

以下代码需要修复。

Sub Macro2()

'Load data from Excel Table to Variant

For i = 1 To 3
    'The following codes need to be repaired.
    'Dim "Variant" & i As Variant
    '"Variant" & i = Worksheets(i).ListObjects(1).DataBodyRange
Next i

End Sub

我尝试了使用 Scripting.Dictionary 作为 BigBen 推荐的替代方法。但以下代码需要修复。

Sub Macro3()

    Dim dict As Object
    Set dict = Nothing
    Set dict = CreateObject("Scripting.Dictionary")
    dict.RemoveAll
    
    For i = 1 To 3
        dict.Add Key:=i, Item:=Worksheets(i).ListObjects(1).DataBodyRange
    Next i
     
End Sub

Answer 1

您可以使用数组：

Sub Macro3()

    Dim data(1 To 3) As Variant, i As Long, r As Long, arr
    
    For i = 1 To 3
        data(i) = ThisWorkbook.Worksheets(i).ListObjects(1).DataBodyRange.Value
    Next i
    
    For i = 1 To 3
        arr = data(i)
        For r = 1 To UBound(arr, 1)
            Debug.Print arr(r, 3)
        Next r
    Next i
     
End Sub

Answer 2

转换为Excel表格后循环特定数据列(

ListObject

)

之前

之后

Sub ConvertToTables()
    
    Debug.Print "Running ""ConvertToTables""..."
    
    Const SEARCH_COLUMN As Long = 3

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' If it's not, specify it correctly.
    ' If it's the active workbook, use 'Set wb = ActiveWorkbook' instead.

    Dim ws As Worksheet, rg As Range, lo As ListObject
    Dim Data As Variant, rCount As Long, r As Long
    
    For Each ws In wb.Worksheets
        Set rg = ws.Range("A1").CurrentRegion
        On Error Resume Next
            Set lo = ws.ListObjects.Add(SourceType:=xlSrcRange, _
                Source:=rg, XlListObjectHasHeaders:=xlYes)
        On Error GoTo 0
        If Not lo Is Nothing Then
            rCount = lo.ListRows.Count
            If rCount > 0 And lo.ListColumns.Count >= SEARCH_COLUMN Then
                Debug.Print ws.Name, lo.Name
                ' Either...
                With lo.ListColumns(SEARCH_COLUMN).DataBodyRange
                    If rCount = 1 Then ' single row
                        ReDim Data(1 To 1, 1 To 1)
                        Data(1, 1) = .Value
                    Else ' multiple rows
                        Data = .Value
                    End If
                End With
                For r = 1 To rCount
                    Debug.Print r, rCount, Data(r, 1)
                Next r
                ' ... or, if you need the values in the other columns:
                'Data = lo.DataBodyRange.Value
                'For r = 1 To rCount
                '    Debug.Print r, Data(r, SEARCH_COLUMN)
                'Next r
            Else ' no data
                Debug.Print "Table """ & lo.Name & """ has no data."
            End If
            Set lo = Nothing
        Else
            Debug.Print "... probably overlaps with an existing table"
        End If
    Next ws
        
End Sub

Sub ConvertToRanges()
    
    Debug.Print "Running ""ConvertToRanges""..."
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' If it's not, specify it correctly.
    ' If it's the active workbook, use 'Set wb = ActiveWorkbook' instead.
    
    Dim ws As Worksheet, lo As ListObject, RangeRowsCount As Long
    
    For Each ws In wb.Worksheets
        On Error Resume Next ' prevent error if table doesn't exist
            Set lo = ws.ListObjects(1)
        On Error GoTo 0
        If Not lo Is Nothing Then ' table exists
            Debug.Print "Clearing table """ & lo.Name & """!"
            RangeRowsCount = lo.ListRows.Count + 1
            If RangeRowsCount = 1 Then RangeRowsCount = 2
            lo.Unlist
            ws.Range("A1").CurrentRegion.Resize(RangeRowsCount).ClearFormats
            Set lo = Nothing
        Else ' table doesn't exist
            Debug.Print "No table found in """ & ws.Name & """!"
        End If
    Next ws

End Sub

• 连续运行每个程序两次后，立即窗口（Ctrl+G）显示：

Running "ConvertToTables"...
Sheet1        Table31
 1             4             34 
 2             4             48 
 3             4             14 
 4             4             74 
Sheet2        Table32
 1             3             70 
 2             3             17 
 3             3             84 
Table "Table33" has no data.
Running "ConvertToTables"...
... probably overlaps with an existing table
... probably overlaps with an existing table
... probably overlaps with an existing table
Running "ConvertToRanges"...
Clearing table "Table31"!
Clearing table "Table32"!
Clearing table "Table33"!
Running "ConvertToRanges"...
No table found in "Sheet1"!
No table found in "Sheet2"!
No table found in "Sheet3"!