Question

我有一些数据，显示从一个合伙人到另一合伙人的财产获取和财产转移。基于非活动日期，然后查看文档日期，我必须检测财产的转移。这是数据的快照：

例如，在第二张图片中，当合同无效日期过去时，所有权转移到第二天的其他具有文档日期的所有权。就像第一组中的第13个William G＆ALMA一样，现在都没有活动的日期是10/3/1971，现在我将在我为ALMA TEST TR找到10/4/1971的文档日期中找到第二天的日期，因此，所有权转移给他和新的合作伙伴是WILLIAM G＆ALMA TEST TR，因为两者都拥有100％的所有权。这里是我手动完成的输出，但是我需要VBA代码来简化它，因为我是VBA的新手，这是必需的输出。

这是我的代码：

Sub DateFill()
Dim rng As Range, destRow As Long
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim c As Range '-- this is used to store the single cell in the For Each loop

Set shtSrc = Sheets("Input") ' Sets "Sheet1" sheet as source sheet
Set shtDest = Sheets("Output") 'Sets "Sheet2." sheet as destination sheet
destRow = 2 'Start copying to this row on destination sheet

    Dim x, y, i As Long
    y = Array("ERROR", "(ERROR)") ' To delete rows having the name error to clean data

    With ActiveSheet.UsedRange.Columns(1)
        x = .Value
        For i = 1 To UBound(x, 1)
            If Not IsError(Application.Match(LCase(x(i, 1)), y, 0)) Then x(i, 1) = ""
        Next
        .Value = x
        .SpecialCells(4).EntireRow.Delete
    End With

' >> Look for matching dates in columns F to G <<
For Each c In rng.Cells
    If (c.Offset(0, 2).Value + 1 = c.Offset(1, 3).Value) Then

        shtSrc.Range("A" & c.Row).Copy shtDest.Range("A" & destRow)
        shtSrc.Range("B" & c.Row).Copy shtDest.Range("B" & destRow)
        shtSrc.Range("C" & c.Row).Copy shtDest.Range("C" & destRow)
        shtSrc.Range("D" & c.Row).Copy shtDest.Range("D" & destRow)
        shtSrc.Range("E" & c.Row).Copy shtDest.Range("E" & destRow)
        shtSrc.Range("F" & c.Row).Copy shtDest.Range("F" & destRow)
        shtSrc.Range("G" & c.Row).Copy shtDest.Range("G" & destRow)



        destRow = destRow + 1

' > Ends search for dates <
    End If
Next

End Sub

这超出了我的知识水平。任何帮助将不胜感激，因为我似乎无法弄清楚这段代码。如果您可以简单地解释它的工作原理，那将同样棒！

Answer 1

我将以下数据用作工作表"Data"。请注意，列必须严格按照此顺序和位置排列。该代码按A，B，C…来寻址列。

请注意，我使用了另一种日期格式，但是该代码也可以与其他任何日期格式一起使用，只要单元格包含实际日期而不是字符串即可。

以下代码必须在模块中。您需要指定工作表名称。

Option Explicit

Global wsData As Worksheet
Global wsDest As Worksheet
Global LastRow As Long
Global LastCol As Long
Global GroupCounter As Long

Public Sub ExtractGroups()
    Set wsData = ThisWorkbook.Worksheets("Data")                         'specify source sheet
    Set wsDest = ThisWorkbook.Worksheets("Groups")                       'specify destination sheet
    LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    LastCol = wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column
    GroupCounter = 0

    '## Sort data
    With wsData.Sort
        .SortFields.Clear
        'sort by Acquistion Date, Document Date and Inactive Date
        .SortFields.Add Key:=Range("E2:E" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("F2:F" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("G2:G" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

        .SetRange wsData.UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    '## Find first group
    Dim iRow As Long
    iRow = LastRow

    Dim IntSum As Double
    Do While IntSum + wsData.Cells(iRow, "C").Value <= 100
        IntSum = IntSum + wsData.Cells(iRow, "C").Value

        Application.CutCopyMode = False
        wsDest.Rows(2).Insert xlDown
        wsData.Rows(iRow).Resize(ColumnSize:=LastCol).Copy
        wsDest.Rows(2).Cells(1, "A").Value = GroupCounter
        wsDest.Rows(2).Cells(1, "B").PasteSpecial xlPasteAll
        iRow = iRow - 1
    Loop

    '## Analyze the data
    Dim GroupRows As Long
    GroupRows = LastRow - iRow

    Dim destRow As Long, FirstGroupRow As Long, FirstDate As Date, AddedRows As Long
    Do While GroupRows >= 0
        GroupCounter = GroupCounter + 1
        FirstGroupRow = 2
        AddedRows = 0
        destRow = 2 + GroupRows - 1
        FirstDate = 0
        GroupRows = 0

        Do While destRow + GroupRows >= FirstGroupRow + GroupRows
            If FirstDate = 0 Then
                If Not IsDate(wsDest.Cells(destRow + GroupRows, "H").Value) Then Exit Do
                FirstDate = wsDest.Cells(destRow + GroupRows, "H").Value
                GroupRows = GroupRows + AddNextOwners(wsDest.Cells(destRow + GroupRows, "H").Value + 1)
            ElseIf FirstDate <> wsDest.Cells(destRow + GroupRows, "H").Value Then
                GroupRows = GroupRows + 1

                Application.CutCopyMode = False
                wsDest.Rows(2).Insert xlDown
                wsDest.Rows(destRow + GroupRows).Resize(ColumnSize:=LastCol - 1).Offset(ColumnOffset:=1).Copy
                wsDest.Rows(2).Cells(1, "A").Value = GroupCounter
                wsDest.Rows(2).Cells(1, "B").PasteSpecial xlPasteAll
            End If

            destRow = destRow - 1
        Loop

        If GroupRows = 0 Then Exit Do

        '## Sort within the group
        With wsDest.Sort
            .SortFields.Clear
            .SortFields.Add Key:=wsDest.Range("H2").Resize(RowSize:=GroupRows), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SetRange wsDest.Rows("2").Resize(RowSize:=GroupRows)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        '## color every second group
        With wsDest.Rows("2").Resize(RowSize:=GroupRows).Interior
            If GroupCounter Mod 2 = 0 Then
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent4
                .TintAndShade = 0.799981688894314
                .PatternTintAndShade = 0
            Else
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End If
        End With


        '## check if group int exceeds 100 %
        If Application.WorksheetFunction.Sum(wsDest.Range("D2").Resize(RowSize:=GroupRows)) > 100 Then
            MsgBox "'Int' in group " & GroupCounter & " exceeded 100 %. Please fix the source data.", vbCritical
            'ReNumberGroups
            Exit Sub
        End If
        DoEvents
    Loop

    'ReNumberGroups

    '## everything was going correctly!
    MsgBox "Mission accomplished!", vbInformation
End Sub

'## Substitute the old owner with the new ones (for the next group)
Private Function AddNextOwners(DocDate As Date) As Long
    Dim iRow As Long
    For iRow = LastRow To 2 Step -1
        If wsData.Cells(iRow, "F").Value = DocDate Then
            AddNextOwners = AddNextOwners + 1

            Application.CutCopyMode = False
            wsDest.Rows(2).Insert xlDown
            wsData.Rows(iRow).Resize(ColumnSize:=LastCol).Copy
            wsDest.Rows(2).Cells(1, "A").Value = GroupCounter
            wsDest.Rows(2).Cells(1, "B").PasteSpecial xlPasteAll
        End If
    Next iRow
End Function

它将以下面的工作表"Groups"结尾。

请注意，由于某些数据不一致，该算法最终失败了。

如果您要使用相反的组号…

Private Sub ReNumberGroups()
    Dim iRow As Long

    Const StartGroupNumber As Long = 1 'define first group number

    For iRow = 2 To wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row
        wsDest.Cells(iRow, "A").Value = GroupCounter - wsDest.Cells(iRow, "A").Value + StartGroupNumber
    Next iRow
End Sub

使用excel VBA的所有权合作伙伴分组

1 个答案: