Question

我目前正在创建一个自动化程序，该程序将为每个商店分离水果。基本上，我的文件如下所示：

我需要做的是将商店X和B的所有水果转移到列F（来自不同商店的所有水果）。商店的数量和水果都可以增长。

我有下面的代码，但是，它只能得到第一个结果，并且已经跳转到下一个商店。

Sub test()
    Dim i, lastrow As Long
    lastrow = ActiveSheet.Cells(Worksheets(1).Rows.Count, "A").End(xlUp).Row 

    For i = 2 To lastrow
        Cells(i, 1).Select

        If Cells(i, 1).Value <> "" Then
            Cells(i, 6) = Cells(i, 4).Value
        End If
    Next i
End Sub

我正在考虑为水果添加另一个lastrow计数，但是它一直持续到D列的最后一行。

Answer 1

我建议以下内容：

Option Explicit

Public Sub CopyFruitsIntoStores()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet 'if this code is for a specific sheet only then better define a sheet like Thisworkbook.Worksheets("NameOfSheet")

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row 'find last row in col D it is longer than A

    Dim iStore As Long 'to count the stores

    Dim iRow As Long
    For iRow = 2 To LastRow
        If ws.Cells(iRow, 1).Value <> vbNullString Then 'if a new store begins
            iStore = iStore + 1
            'Use following line to write the headers for the stores
            ws.Cells(1, 5 + iStore).Value = ws.Cells(iRow, 1).Value & " (Fruits)"
        End If
        ws.Cells(iRow, 5 + iStore).Value = ws.Cells(iRow, 4).Value
    Next iRow
End Sub

对iStore中的商店进行计数，并使用该商店计数来确定目标列。

还要注意，您需要确定D列中的LastRow而不是A。D列的条目比A的条目多。如果您使用A的最后一行，它会停止得太早。

Answer 2

以下内容应满足您的要求，我检查D列的最后一行而不是A列，因为这些是您要转置的值：

Sub test()
    Dim i As Long, lastrow As Long
    lastrow = ActiveSheet.Cells(Worksheets(1).Rows.Count, "D").End(xlUp).Row
    For i = 2 To lastrow
        Cells(i, 1).Select
            If i < 6 Then
                Cells(i, 6) = Cells(i, 4).Value
            Else
                Cells(i, 7) = Cells(i, 4).Value
        End If
    Next i
End Sub

Answer 3

首先尝试使用以下功能获取“最后一行”，这非常方便。

Function LastRow(sh As Worksheet) As Integer
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlValues, _
       SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function

最后一列还有一个，以防将来参考。

Function LastColumn(sh As Worksheet) As Integer
On Error Resume Next
LastColumn = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlValues, _
       SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
On Error GoTo 0
End Function

现在是实际的工作程序

Sub test()
Dim i as Long, InptClm as integer  'good to define the variable otherwise they will be considered as variant which is at higher memory rank.
Dim LastRow As Integer: LastRow = LastRow(activeworkbook.Sheets("Type sheet name here")

With activeworkbook.Sheets("Type Sheet Name here")
For i = 2 To lastrow
    ' you don't have to select here as selection slows the performance of codes.
    If .Cells(i, 1).Value <> "" Then
        ' Below code will make the column selection dynamic
        inptclm = .rows(1).find(What:=.cells(i,1)&" (Fruits)",After:=Cells(1,1),Lookat:=xlwhole).column()
    End If
        .Cells(i, inptclm) = Cells(i, 4).Value
Next I
end with
End sub

-代码未经测试，希望它能够为您提供帮助。

Answer 4

您可以使用SpecialCells隔离A列中的每个空白单元格组

Option Explicit

Public Sub test()

    Dim iArea As Long
    For Each area in Range("D2", Cells(Rows.Count, "D").End(xlUp)).Offset(,-3).SpecialCells(xlCellTypeBlanks).Areas
        With area.Offset(-1).Resize(.Rows.Count + 1)
            Range("F1").Offset(,iArea).Value = .Cells(1,1).Value
            Range("F2").Offset(,iArea).Resize(.Rows.Count).Value = .Value
        End With 
        iArea = iArea + 1
    Next
End Sub

Excel VBA：遍历第一行的另一列上的单元格

4 个答案: