从Excel数据库中提取数据 [英] Extracting Data from Excel Database
问题描述
我有一个包含一长串名称以及与名称相关联的唯一值的数据库.我想做的是为每个人创建一个工作表,然后仅将其数据复制到工作表中的指定范围,然后继续到下一个个人,将其数据复制到工作表中,等等.
I've got a database with a long list of names, and unique values associated with the names. What I want to do is create one worksheet for each individual, and then copy only their data to a specified range in their worksheet, then proceed to the next individual, copy their data to their worksheet etc.
此处是示例工作表的链接(在google docs表单中,请注意-我实际上正在使用Excel 2010 ,而不是Google文档).
Here is a link to an example worksheet (in google docs form, note - I am actually using Excel 2010, not google docs).
通过在名为"Employee"的新工作表中使用以下代码,我已经能够创建所有工作表.我对此工作表所做的只是删除了重复的名称值,因此我可以获得工作表中所有名称的列表.
I've been able to create all the worksheets through using the following code in a new sheet I called "Employee". All I did to this sheet was remove the duplicate name values so I could have a list of all the names for the worksheets.
我们非常感谢您的帮助.预先感谢.
Any help is much appreciated. Thanks in advance.
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
推荐答案
裸露骨头的方法-可以进行优化以提高性能,但可以完成工作.
Bare bones approach - could be optimized for better performance, but it will do the job.
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
这篇关于从Excel数据库中提取数据的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!