0

我这里有一些代码可以为 A 列中的每个唯一单元格创建一个新的模板表。然后它将 E、F、L 和 O 列分配到新创建的模板表中的适当位置。

但是，它将数据表 E 列中的值放入创建的模板表的末尾。我将如何使它从第 4 行开始，这是值的空白单元格的开始。

此外，如果有人可以帮助使用一个新命令，如果模板表上已经有 F 列值，则该命令不会将同一行放入模板中。

Sub Redemption()

Dim wsDatatable As Worksheet
Dim wsTempelate As Worksheet
Dim rangeFound As Range
Dim rangeNames As Range
Dim NameCells As Range
Dim stringFirst As String
Dim stringNames As String
Dim stringUniqueNames As String

    Set wsDatatable = Sheets("DATA INPUT TABLE")
    Set wsTempelate = Sheets("CLASS GROUPING ID")
    Set rangeNames = wsDatatable.Range("A2", wsDatatable.Cells(Rows.Count, "A").End(xlUp))

    For Each NameCells In rangeNames.Cells
        If InStr(1, "|" & stringUniqueNames & "|", "|" & NameCells.Text & "|", vbTextCompare) = 0 Then
            stringUniqueNames = stringUniqueNames & "|" & NameCells.Text
            Set rangeFound = rangeNames.Find(NameCells.Text, rangeNames.Cells(rangeNames.Cells.Count), xlValues, xlWhole)
            If Not rangeFound Is Nothing Then
                stringFirst = rangeFound.Address
                stringNames = NameCells.Text
                stringNames = Trim(Left(WorksheetFunction.Trim(stringNames), 31))
                If Evaluate("IsRef('" & stringNames & "'!A1)") = False Then
                    wsTempelate.Copy After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = stringNames
                End If
                With Sheets(stringNames)
                    Do
                        If LCase(wsDatatable.Cells(rangeFound.Row, "I").Text) = "full liquidation" Or LCase(wsDatatable.Cells(rangeFound.Row, "I").Text) = "redemption" Then
                            .Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = wsDatatable.Cells(rangeFound.Row, "E").Value
                            .Cells(Rows.Count, "B").End(xlUp).Offset(1).Value = wsDatatable.Cells(rangeFound.Row, "F").Value
                            .Cells(Rows.Count, "C").End(xlUp).Offset(1).Value = wsDatatable.Cells(rangeFound.Row, "B").Value
                            .Cells(Rows.Count, "D").End(xlUp).Offset(1).Value = wsDatatable.Cells(rangeFound.Row, "O").Value
                            .Cells(Rows.Count, "E").End(xlUp).Offset(1).Value = wsDatatable.Cells(rangeFound.Row, "L").Value
                        End If
                        Set rangeFound = rangeNames.Find(NameCells.Text, rangeFound, xlValues, xlWhole)
                    Loop While rangeFound.Address <> stringFirst
                End With
            End If
        End If
    Next NameCells

    Set wsDatatable = Nothing
    Set wsTempelate = Nothing
    Set rangeFound = Nothing
    Set rangeNames = Nothing
    Set NameCells = Nothing

End Sub
4

1 回答 1

0

通过一些更改，您可以重写代码以使其开始填充第 4 行的值并防止重复插入（如果模板表上已经有 F 列值），这样：

Sub Redemption()

Dim wsDatatable As Worksheet
Dim wsTempelate As Worksheet
Dim rangeFound As Range
Dim rangeNames As Range
Dim NameCells As Range
Dim stringFirst As String
Dim stringNames As String
Dim stringUniqueNames As String


Set wsDatatable = Sheets("DATA INPUT TABLE")
Set wsTempelate = Sheets("CLASS GROUPING ID")
Set rangeNames = wsDatatable.Range("A2", wsDatatable.Cells(Rows.Count, "A").End(xlUp))

For Each NameCells In rangeNames.Cells
    If InStr(1, "|" & stringUniqueNames & "|", "|" & NameCells.Text & "|", vbTextCompare) = 0 Then
        stringUniqueNames = stringUniqueNames & "|" & NameCells.Text
        Set rangeFound = rangeNames.Find(NameCells.Text, rangeNames.Cells(rangeNames.Cells.Count), xlValues, xlWhole)
        If Not rangeFound Is Nothing Then
            stringFirst = rangeFound.Address
            stringNames = NameCells.Text
            stringNames = Trim(Left(WorksheetFunction.Trim(stringNames), 31))
            If Evaluate("IsRef('" & stringNames & "'!A1)") = False Then
                wsTempelate.Copy After:=Sheets(Sheets.Count)
                ActiveSheet.Name = stringNames
            End If


            Dim AR, BR, CR, DR, ER As Integer ' row pointers for columns A to E
            Dim st As Boolean
            With Sheets(stringNames)


                Do
                    If LCase(wsDatatable.Cells(rangeFound.Row, "I").Text) = "full liquidation" Or LCase(wsDatatable.Cells(rangeFound.Row, "I").Text) = "redemption" Then
                        AR = .Cells(.Rows.Count, "A").End(xlUp).Row ' determines last not empty cell on column A
                        BR = .Cells(.Rows.Count, "B").End(xlUp).Row ' determines last " " cell on column B
                        CR = .Cells(.Rows.Count, "C").End(xlUp).Row ' determines last " " cell on column C
                        DR = .Cells(.Rows.Count, "D").End(xlUp).Row ' determines last " " cell on column D
                        ER = .Cells(.Rows.Count, "E").End(xlUp).Row ' determines last " " cell on column E
                        f_row = 3
                        If AR < f_row Then AR = f_row '
                        If BR < f_row Then BR = f_row '
                        If CR < f_row Then CR = f_row '       move pointers to row 3 on each column, when lower than that
                        If DR < f_row Then DR = f_row '
                        If ER < f_row Then ER = f_row ' notice it will start only after f_row since it's called afterwards with Offset(1)...
                                                  '
                        st = True ' this boolean variable will be turned to FALSE when a row is already present in template sheet, preventing it from filling up
                        Dim strA As String
                        Set fRange = Sheets(stringNames).Range("A1", "A" & CStr(AR + 1)) 'set range to start searching for duplicate identifiers
                        For Each nv In fRange
                            If wsDatatable.Cells(rangeFound.Row, "F").Value = nv Then st = False 'if there's a duplicate, turn st to FALSE
                        Next nv
                        If st = True Then
                            .Cells(AR, "A").Offset(1).Value = wsDatatable.Cells(rangeFound.Row, "F").Value
                            .Cells(BR, "B").Offset(1).Value = wsDatatable.Cells(rangeFound.Row, "B").Value
                            .Cells(CR, "C").Offset(1).Value = wsDatatable.Cells(rangeFound.Row, "O").Value
                            .Cells(DR, "D").Offset(1).Value = wsDatatable.Cells(rangeFound.Row, "L").Value
                            .Cells(ER, "E").Offset(1).Value = wsDatatable.Cells(rangeFound.Row, "E").Value
                        End If
                    End If
                    Set rangeFound = rangeNames.Find(NameCells.Text, rangeFound, xlValues, xlWhole)
                Loop While rangeFound.Address <> stringFirst
            End With
        End If
    End If
Next NameCells

Set wsDatatable = Nothing
Set wsTempelate = Nothing
Set rangeFound = Nothing
Set rangeNames = Nothing
Set NameCells = Nothing

End Sub
于 2013-06-21T19:42:52.517 回答