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 に答える