excel - 操作列 VBA

Question

我已经为我的庞大数据集 VBA 编写了以下代码，我希望根据我的范围标准来操作列，请帮助。

Dim Ary As Variant, Nary As Variant
   
    Dim r As Long, Rw As Long
   
    With Sheets("Sheet1")

        Ary = .Range("A2:B" & .Range("A" & Rows.Count).End(xlUp).Row).Value2

    End With

    ReDim Nary(1 To UBound(Ary), 1 To 1)
 
    With CreateObject("scripting.dictionary")
      
        For r = 1 To UBound(Ary)
         
            If Not .Exists(Ary(r, 1)) Then

                .Add Ary(r, 1), r

                Nary(r, 1) = Ary(r, 2)

            Else
        
                Rw = .Item(Ary(r, 1))
        
                Nary(Rw, 1) = Nary(Rw, 1) + Ary(r, 2)

            End If

        Next r

    End With

    Sheets("sheet1").Range("C2").Resize(UBound(Nary)).Value = Nary

Sheets("sheet1").Range("C2").Resize(UBound(Nary)).Value = Nary

我想按照以下标准重新排列列，

ColumnA = ColumnD (4)

ColumnB = ColumnN (14)

ColumnC - ColumnO (15)

请按照上述标准在 Ubound 和 Lbound 编码之上重新编码，因为我不太习惯使用数组

功能代码。

上面的编码工作正常我只想操作列。

谢谢

标签： excelvbaexcel-formulaexcel-2007

Answer 1

获得第一笔款项

• 下面总结了另一列中每个唯一值的列中的值，并在每个唯一值第一次出现的行中的第三列中显示结果。

Option Explicit

Function getFirstSums( _
    ws As Worksheet, _
    ByVal LookUpColumn As Variant, _
    ByVal ValuesColumn As Variant, _
    Optional ByVal FirstRow As Long = 1) _
As Variant

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, LookUpColumn).End(xlUp).Row
    
    Dim rng As Range
    Set rng = ws.Cells(FirstRow, LookUpColumn).Resize(LastRow - FirstRow + 1)
    
    Dim Lookup As Variant: Lookup = rng.Value
    Dim SumUp As Variant
    SumUp = rng.Offset(, ws.Columns(ValuesColumn).Column _
        - ws.Columns(LookUpColumn).Column).Value
    
    Dim rCount As Long: rCount = UBound(Lookup)
    Dim Result As Variant: ReDim Result(1 To rCount, 1 To 1)
    
    Dim r As Long, rw As Long
    
    With CreateObject("Scripting.Dictionary")
        For r = 1 To rCount
            If Not .Exists(Lookup(r, 1)) Then
                .Add Lookup(r, 1), r
                Result(r, 1) = SumUp(r, 1)
            Else
                rw = .Item(Lookup(r, 1))
                Result(rw, 1) = Result(rw, 1) + SumUp(r, 1)
            End If
        Next r
    End With
    
    getFirstSums = Result

End Function

Sub TESTgetFirstSums()
    
    Const wsName As String = "Sheet1"
    Const LookUpColumn As Variant = "D"
    Const ValuesColumn As Variant = "N"
    Const ResultColumn As Variant = "O"
    Const FirstRow As Long = 2
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Dim ary As Variant
    ary = getFirstSums(ws, LookUpColumn, ValuesColumn, FirstRow)

    ws.Range(ResultColumn & FirstRow).Resize(UBound(ary)).Value = ary

End Sub

Sub TESTgetFirstSumsSimple()
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Dim ary As Variant
    ary = getFirstSums(ws, 4, 14, 2)

    ws.Cells(2, 15).Resize(UBound(ary)).Value = ary

End Sub

编辑：

• 或者你可能宁愿把它写成一个子过程：

---

Sub writeFirstSums( _
        ws As Worksheet, _
        ByVal LookUpColumn As Variant, _
        ByVal ValuesColumn As Variant, _
        ByVal ResultColumn As Variant, _
        Optional ByVal FirstRow As Long = 1)

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, LookUpColumn).End(xlUp).Row
    
    Dim rng As Range
    Set rng = ws.Cells(FirstRow, LookUpColumn).Resize(LastRow - FirstRow + 1)
    
    Dim Lookup As Variant: Lookup = rng.Value
    Dim SumUp As Variant
    SumUp = rng.Offset(, ws.Columns(ValuesColumn).Column _
        - ws.Columns(LookUpColumn).Column).Value
    
    Dim rCount As Long: rCount = UBound(Lookup)
    Dim Result As Variant: ReDim Result(1 To rCount, 1 To 1)
    
    Dim r As Long, rw As Long
    
    With CreateObject("Scripting.Dictionary")
        For r = 1 To rCount
            If Not .Exists(Lookup(r, 1)) Then
                .Add Lookup(r, 1), r
                Result(r, 1) = SumUp(r, 1)
            Else
                rw = .Item(Lookup(r, 1))
                Result(rw, 1) = Result(rw, 1) + SumUp(r, 1)
            End If
        Next r
    End With
    
    ws.Cells(FirstRow, ResultColumn).Resize(UBound(Result)) = Result

End Sub

Sub TESTwriteFirstSumsSimple()
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    writeFirstSums ws, 4, 14, 15, 2

End Sub