从Excel数据库中提取数据

我有一个数据库，其中包含一长串名称以及与名称关联的唯一值。我想要做的是为每个人创建一个工作表，然后将他们的数据复制到工作表中的指定范围，然后继续到下一个人，将他们的数据复制到他们的工作表等。从Excel数据库中提取数据

Here是一个链接到一个示例工作表（在谷歌文档形式，请注意 - 我实际上使用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

来源

2013-10-10 user2829172

那么究竟是什么问题？ –

我在我的实际文档中有大约200多个人名，每个独特的名字大约有200行左右的数据。我正在寻找一种方法来自动选择一个名称的所有数据点，将它们粘贴到与该名称对应的工作表上，然后移至列表中的下一个唯一名称。手动执行此操作（对名称使用过滤器）需要很长时间，并且容易出错。 – user2829172

光秃秃的骨头的方法 - 可以优化更好的性能，但它会做的工作。

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-10 16:35:19

完美。这正是我所期待的。谢谢。 – user2829172

从Excel数据库中提取数据

回答

相关问题