엑셀 데이터베이스에서 데이터 추출

Question

나는 긴 이름 목록과 이름과 관련된 고유 한 값을 가진 데이터베이스를 가지고있다. 내가하고 싶은 일은 각 개인에 대해 하나의 워크 시트를 만든 다음 워크 시트의 지정된 범위로 데이터를 복사 한 후 다음 개인으로 진행하여 데이터를 워크 시트 등에 복사하는 것입니다.

Here은 링크입니다. 예제 워크 시트 (Google 워드 프로세서 양식, 메모 - 실제로 Google 워드 프로세서가 아닌 Excel 2010을 사용 중입니다).

"Employee"라는 새 시트에 다음 코드를 사용하여 모든 워크 시트를 만들 수있었습니다. 내가이 시트에 한 것은 워크 시트의 모든 이름 목록을 가질 수 있도록 중복 된 이름 값을 제거하는 것이 었습니다.

도움을 주시면 감사하겠습니다. 미리 감사드립니다.

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 

Answer 1

베어 본 접근 - 더 나은 성능을 위해 최적화 될 수 있지만 작업을 수행합니다.

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