使用范围对象作为循环的一部分

Question

我在下面粘贴了整个宏，但这是重要的部分。

Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value    
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value    
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value    
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value

它按原样工作，只是它创建了不必要的数据，因为我不知道如何在范围对象中使用变量名。我的范围目前是硬编码的，例如 ("A1:A1000")，而我希望它类似于 ("A1:A & LastRow)。

我还必须明确地调用要复制的列名，因为该范围不会接受像 ("currentColumn & 1:currentColumn & LastRow) 这样的变量名。

有没有办法将变量名称用作范围对象的一部分，以便我们可以在循环中使用它们？

Sub prepareWorkbook()

Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim wks As Worksheet
Set wks = wbk.ActiveSheet
Dim colx As Long
Dim ColumnCount As Long
Dim MySheetName As String
MySheetName = "Import"
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName

'identify the Id column and move it to 1st column
Dim answer As Variant
Dim IdColumn As Range
answer = Application.InputBox("Enter Letter of Id column")

If Columns(answer).Column = 1 Then
Else
    'cut Id column from current location and insert it at column index 1
    Columns(answer).Select
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
End If

'trim the PartNumber column of any trailing spaces
Dim c As Range
For Each c In Range("A1:A10000")
    c.Value = Application.Trim(Replace(c.Value, Chr(160), Chr(32)))
Next

' insert column every other column
' Loop through number of columns.
ColumnCount = Application.WorksheetFunction.CountA(Rows(1)) * 2

'step 2 means skip every other
For colx = 2 To ColumnCount Step 2
    Columns(colx).Insert Shift:=xlToRight
Next

Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value    
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value    
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value    
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value

wks.Cells.EntireColumn.AutoFit
MsgBox ("Done")

结束子

Answer 1

假设您在此处添加的工作表中运行代码：

'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName

也不确定这段代码的目的是什么，但还是将它用于示例

Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value

试试这个：

Dim lLastRow As Long
lLastRow = wbk.Worksheets(MySheetName).UsedRange.SpecialCells(xlLastCell).Row

Rem This updates only columns B, D, F & H - adjust as needed
For colx = 2 To 8 Step 2
    With wbk.Worksheets(MySheetName)
        Rem Creates Range as Range(Cells(rIni,cIini), Cells(rEnd,cEnd))
        rem Corresponding code for "Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value" (see comment above)
        Range(.Cells(2, colx), .Cells(lLastRow, colx)) = .Cells(2, colx).Offset(-1, 1).Value
End With: Next

Answer 2

类似：

Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2:B" & LastRow).Value = Range("B2").Offset(-1, 1).Value
Range("D2:D" & LastRow).Value = Range("D2").Offset(-1, 1).Value
Range("F2:F" & LastRow).Value = Range("F2").Offset(-1, 1).Value
Range("H2:H" & LastRow).Value = Range("H2").Offset(-1, 1).Value

Answer 3

虽然此答案不适用于您的情况，但我觉得这可以帮助您回答其中的一些问题。

指定范围时，可以将列（字母）和行（数字）分开，并使用自己的变量。 在 for 循环中，这可能看起来像

for i = 1 to 100
     Range("A" & i).Value = Range("A"&i).Offset(, 1).Value
next

您还可以使用以下方法确定所选单元格的行数：

dim RowNb as long
RowNb = (ActiveCell.Row)

这也适用于列，并且可以像我在开头提到的那样在循环中使用。

Answer 4

在您的描述中没有提及的一件事是对工作表中数据的性质的任何提及。您简要提到了A1，但您的范围值分配从第 2 行开始，因此可以推断第 1 行包含列标题标签。

Sub prepareWorkbook()
    Dim wbk As Workbook, wks As Worksheet
    Dim colx As Long
    Dim lc As Long, lr As Long
    Dim MySheetName As String

    Set wbk = ThisWorkbook    'no idea what this does
    Set wks = wbk.ActiveSheet 'no idea what this does
    MySheetName = "Import"

    'no idea what this does or what sht is
    'LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

    'copy the worksheet and rename it before editing
    Sheets(1).Copy After:=Sheets(1)

    With Sheets(2)
        .Name = MySheetName

        If CBool(Application.CountIf(.Rows(1), "PartNumber")) Then
            colx = Application.Match("PartNumber", .Rows(1), 0)
        Else
            colx = .Range(Application.InputBox("Enter Letter of Id column") & 1).Column
        End If
        If .Columns(colx).Column > 1 Then
            'cut Id column from current location and insert it at column index 1
            .Columns(colx).Cut
            .Columns(1).Insert Shift:=xlToRight
        End If

        'quickest way to trim trailing spaces is with Text-to-Columns, Fixed Width
        With .Columns(1)
            .TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1)
        End With

        ' insert column every other column (working backwards toward A1)
        For lc = .Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
            .Columns(lc).Insert Shift:=xlToRight
        Next lc

        For lc = (.Cells(1, Columns.Count).End(xlToLeft).Column - 1) To 2 Step -2
            'let's put the row-by-row value in instead of a single value into all cells
            lr = .Cells(Rows.Count, lc + 1).End(xlUp).Row
            With .Cells(2, lc).Resize(lr - 1, 1)
                .Cells = .Offset(-1, 1).Value
                .EntireColumn.AutoFit
            End With
        Next lc

    End With

    Set wbk = Nothing
    Set wks = Nothing

End Sub

解释为代码中的 cmets。