0

名前の長いリストと、名前に関連付けられた一意の値を含むデータベースがあります。私がやりたいことは、個人ごとに1つのワークシートを作成し、ワークシートの指定された範囲にデータのみをコピーしてから、次の個人に進み、データをワークシートにコピーするなどです。

ワークシートの例へのリンクを次に示します (Google ドキュメント フォームで、注 - 私は実際には Google ドキュメントではなく Excel 2010 を使用しています)。

「従業員」という名前の新しいシートで次のコードを使用して、すべてのワークシートを作成できました。このシートに対して行ったのは、ワークシートのすべての名前のリストを取得できるように、重複する名前の値を削除することだけでした。

どんな助けでも大歓迎です。前もって感謝します。

Sub CreateSheetsFromAList()
Dim nameSource      As String 'sheet name where to read names
Dim nameColumn      As String 'column where the names are located
Dim nameStartRow    As Long   'row from where name starts

Dim nameEndRow      As Long   'row where name ends
Dim employeeName    As String 'employee name

Dim newSheet        As Worksheet

nameSource = "Employee"
nameColumn = "A"
nameStartRow = 1


'find the last cell in use
nameEndRow = Sheets(nameSource).Cells(Rows.Count, nameColumn).End(xlUp).Row

'loop till last row
Do While (nameStartRow <= nameEndRow)
    'get the name
    employeeName = Sheets(nameSource).Cells(nameStartRow, nameColumn)

    'remove any white space
    employeeName = Trim(employeeName)

    ' if name is not equal to ""
    If (employeeName <> vbNullString) Then

        On Error Resume Next 'do not throw error
        Err.Clear 'clear any existing error

        'if sheet name is not present this will cause error that we are going to leverage
        Sheets(employeeName).Name = employeeName

        If (Err.Number > 0) Then
            'sheet was not there, so it create error, so we can create this sheet
            Err.Clear
            On Error GoTo -1 'disable exception so to reuse in loop

            'add new sheet
            Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))

            'rename sheet
            newSheet.Name = employeeName


            'paste training material
            Sheets(employeeName).Cells(1, "A").PasteSpecial
            Application.CutCopyMode = False
        End If
    End If
    nameStartRow = nameStartRow + 1 'increment row
Loop
End Sub
4

1 に答える 1

2

必要最小限のアプローチ - パフォーマンスを向上させるために最適化できますが、それでうまくいきます。

Sub SplitToSheets()

Dim c As Range, ws As Worksheet, rngNames

    With ThisWorkbook.Sheets("EmployeeData")
        Set rngNames = .Range(.Range("A1"), .Cells(Rows.Count, 1).End(xlUp))
    End With

    For Each c In rngNames.Cells
        Set ws = GetSheet(ThisWorkbook, c.Value)
        c.EntireRow.Copy ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next c

End Sub


Function GetSheet(wb As Workbook, wsName As String, _
         Optional CreateIfMissing As Boolean = True) As Worksheet

    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Sheets(wsName)
    On Error GoTo 0

    If ws Is Nothing And CreateIfMissing Then
        Set ws = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
        ws.Name = wsName
    End If

    Set GetSheet = ws
End Function
于 2013-10-10T16:35:19.310 に答える