Извлечение данных из базы данных Excel

Question

У меня есть база данных с длинным списком имен и уникальными значениями, связанными с именами. Что я хочу сделать, так это создать один рабочий лист для каждого человека, а затем скопировать только их данные в указанный диапазон на своем листе, а затем перейти к следующему человеку, скопировать данные на их рабочий лист и т. Д.

Here - это ссылка к примеру рабочего листа (в форме документации Google, заметьте - я фактически использую Excel 2010, а не документы Google).

Я смог создать все листы с помощью следующего кода на новом листе, который я назвал «Сотрудник». Все, что я сделал с этим листом, - это удалить повторяющиеся значения имен, чтобы я мог иметь список всех имен для рабочих листов.

Любая помощь очень ценится. Заранее спасибо.

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