您如何根据特定列值将数据从一个 sheet 提取到另外 3 个 sheet？
How do you pull data from one sheet to 3 other sheets based on specific column values?
我想知道如何根据一列的值将 VBA 的数据从一个 sheet 拉到另外 3 个 sheet。
例如
你有 4 个 Sheet。树 1、树 2、树 3、数据
Tree1、Tree2、Tree3 的数据列不同。
Sheet 4称为数据，有不同列的数据，但1列的值是“TreeOne”，“TreeTwo”和“TreeThree”。
我想根据数据sheet.sheet.
中的一列从数据sheet中提取每棵树的数据
Example of the "Data" Sheet
|Colour| Bark| Hight| Season| Specie|
| Brown| Soft| 10 | Summer| Tree 1|
| Brown| hard| 12 | Winter| Tree 2|
| Brown| hard| 14 | Summer| Tree 1|
| Brown| soft| 12 | Winter| Tree 3|
| Brown| hard| 11 | Summer| Tree 2|
因此查询应该从“数据”Sheet 提取到基于“Specie”列的每个特定 sheet。
Example of the "TreeOne" Sheet
|Colour| Bark| Hight| Season| Specie|
| Brown| Soft| 10 | Summer| Tree 1|
| Brown| hard| 14 | Summer| Tree 1|
Example of the "TreeTwo" Sheet
|Colour| Bark| Hight| Season| Specie|
| Brown| hard| 12 | Winter| Tree 2|
| Brown| hard| 11 | Summer| Tree 2|
Example of the "TreeThree" Sheet
|Colour| Bark| Hight| Season| Specie|
| Brown| soft| 12 | Winter| Tree 3|
如您所见，VBA 查询查看“物种”列并根据特定物种将该物种的所有数据提取到为该数据指示的 sheet。
更新标准工作表（AutoFilter）
Option Explicit
Sub UpdateSpeciesWorksheets()
Const sName As String = "Data"
Const sCol As Long = 5
Const CriteriaList As String = "Tree 1,Tree 2,Tree 3"
Const dNamesList As String = "TreeOne,TreeTwo,TreeThree"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
Dim dNames() As String: dNames = Split(dNamesList, ",")
Application.ScreenUpdating = False
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
If sws.AutoFilterMode Then sws.AutoFilterMode = False
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim dws As Worksheet
Dim svrg As Range
Dim n As Long
For n = 0 To UBound(Criteria) ' or 'UBound(dNames)'
' Attempt to reference the destination current ('n') worksheet.
On Error Resume Next
Set dws = wb.Worksheets(dNames(n))
On Error GoTo 0
If dws Is Nothing Then ' worksheet doesn't exist
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dNames(n)
Else ' worksheet exists
dws.UsedRange.Clear ' clear previous values
End If
' Reference the source visible (filtered) range (headers included).
srg.AutoFilter sCol, Criteria(n)
Set svrg = srg.SpecialCells(xlCellTypeVisible)
sws.AutoFilterMode = False ' remove the filter
' Copy the source visible range to the destination worksheet.
svrg.Copy dws.Range("A1")
' ' Copy the column widths.
' With dws.Range("A1")
' srg.Copy
' .PasteSpecial xlPasteColumnWidths
' .Parent.Activate
' .Select
' End With
Set dws = Nothing ' necessary to work correctly on the next iteration
Next n
sws.Activate
Application.ScreenUpdating = True
MsgBox "Species worksheets updated.", vbInformation
End Sub
Option Explicit
Sub ClearData(rngSpecies As Range)
Dim uniqueSpecie As String
Dim rngSpecie As Range
Dim aux As Long
For Each rngSpecie In rngSpecies
If InStr(1, uniqueSpecie, rngSpecie.Value, vbTextCompare) = 0 Then
On Error Resume Next
aux = ThisWorkbook.Worksheets(rngSpecie.Value).Index
If Err.Number = 9 Then
rngSpecie.Activate
MsgBox "Worksheet '" & rngSpecie.Value & "' doesn't exist. Error in cell " & rngSpecie.Address
Exit Sub
End If
uniqueSpecie = uniqueSpecie & rngSpecie.Value & ";"
End If
Next
If uniqueSpecie <> "" Then
uniqueSpecie = Left(uniqueSpecie, Len(uniqueSpecie) - 1)
End If
Dim aSpecies As Variant
aSpecies = Split(uniqueSpecie, ";")
Dim i As Long
For i = LBound(aSpecies) To UBound(aSpecies)
ThisWorkbook.Worksheets(aSpecies(i)).Range("A:E").EntireColumn.ClearContents
'Set the header
ThisWorkbook.Worksheets(aSpecies(i)).Range("A1:E1").Value = ThisWorkbook.Worksheets("data").Range("A1:E1").Value
Next i
End Sub
Sub CopyData()
Dim shtData As Worksheet
Set shtData = ThisWorkbook.Worksheets("data")
'Clear old data ans sets the header
ClearData shtData.Range("E2:E" & ThisWorkbook.Worksheets("data").Range("E2").End(xlDown).Row)
Dim i As Long, j As Long 'i = actual row in data sheet, j = new row in species sheet
i = 2
Do While shtData.Cells(i, 5) <> "" 'species
j = ThisWorkbook.Worksheets(CStr(shtData.Cells(i, 5))).Range("A1048576").End(xlUp).Offset(1, 0).Row
'this does the trick
ThisWorkbook.Worksheets(CStr(shtData.Cells(i, 5))).Range("A" & j & ":E" & j).Value = _
ThisWorkbook.Worksheets("data").Range("A" & i & ":E" & i).Value
i = i + 1
Loop
MsgBox "Done"
End Sub
我想知道如何根据一列的值将 VBA 的数据从一个 sheet 拉到另外 3 个 sheet。
例如
你有 4 个 Sheet。树 1、树 2、树 3、数据
Tree1、Tree2、Tree3 的数据列不同。 Sheet 4称为数据，有不同列的数据，但1列的值是“TreeOne”，“TreeTwo”和“TreeThree”。
我想根据数据sheet.sheet.
中的一列从数据sheet中提取每棵树的数据 Example of the "Data" Sheet
|Colour| Bark| Hight| Season| Specie|
| Brown| Soft| 10 | Summer| Tree 1|
| Brown| hard| 12 | Winter| Tree 2|
| Brown| hard| 14 | Summer| Tree 1|
| Brown| soft| 12 | Winter| Tree 3|
| Brown| hard| 11 | Summer| Tree 2|
因此查询应该从“数据”Sheet 提取到基于“Specie”列的每个特定 sheet。
Example of the "TreeOne" Sheet
|Colour| Bark| Hight| Season| Specie|
| Brown| Soft| 10 | Summer| Tree 1|
| Brown| hard| 14 | Summer| Tree 1|
Example of the "TreeTwo" Sheet
|Colour| Bark| Hight| Season| Specie|
| Brown| hard| 12 | Winter| Tree 2|
| Brown| hard| 11 | Summer| Tree 2|
Example of the "TreeThree" Sheet
|Colour| Bark| Hight| Season| Specie|
| Brown| soft| 12 | Winter| Tree 3|
如您所见，VBA 查询查看“物种”列并根据特定物种将该物种的所有数据提取到为该数据指示的 sheet。
更新标准工作表（AutoFilter）
Option Explicit
Sub UpdateSpeciesWorksheets()
Const sName As String = "Data"
Const sCol As Long = 5
Const CriteriaList As String = "Tree 1,Tree 2,Tree 3"
Const dNamesList As String = "TreeOne,TreeTwo,TreeThree"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
Dim dNames() As String: dNames = Split(dNamesList, ",")
Application.ScreenUpdating = False
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
If sws.AutoFilterMode Then sws.AutoFilterMode = False
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim dws As Worksheet
Dim svrg As Range
Dim n As Long
For n = 0 To UBound(Criteria) ' or 'UBound(dNames)'
' Attempt to reference the destination current ('n') worksheet.
On Error Resume Next
Set dws = wb.Worksheets(dNames(n))
On Error GoTo 0
If dws Is Nothing Then ' worksheet doesn't exist
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dNames(n)
Else ' worksheet exists
dws.UsedRange.Clear ' clear previous values
End If
' Reference the source visible (filtered) range (headers included).
srg.AutoFilter sCol, Criteria(n)
Set svrg = srg.SpecialCells(xlCellTypeVisible)
sws.AutoFilterMode = False ' remove the filter
' Copy the source visible range to the destination worksheet.
svrg.Copy dws.Range("A1")
' ' Copy the column widths.
' With dws.Range("A1")
' srg.Copy
' .PasteSpecial xlPasteColumnWidths
' .Parent.Activate
' .Select
' End With
Set dws = Nothing ' necessary to work correctly on the next iteration
Next n
sws.Activate
Application.ScreenUpdating = True
MsgBox "Species worksheets updated.", vbInformation
End Sub
Option Explicit
Sub ClearData(rngSpecies As Range)
Dim uniqueSpecie As String
Dim rngSpecie As Range
Dim aux As Long
For Each rngSpecie In rngSpecies
If InStr(1, uniqueSpecie, rngSpecie.Value, vbTextCompare) = 0 Then
On Error Resume Next
aux = ThisWorkbook.Worksheets(rngSpecie.Value).Index
If Err.Number = 9 Then
rngSpecie.Activate
MsgBox "Worksheet '" & rngSpecie.Value & "' doesn't exist. Error in cell " & rngSpecie.Address
Exit Sub
End If
uniqueSpecie = uniqueSpecie & rngSpecie.Value & ";"
End If
Next
If uniqueSpecie <> "" Then
uniqueSpecie = Left(uniqueSpecie, Len(uniqueSpecie) - 1)
End If
Dim aSpecies As Variant
aSpecies = Split(uniqueSpecie, ";")
Dim i As Long
For i = LBound(aSpecies) To UBound(aSpecies)
ThisWorkbook.Worksheets(aSpecies(i)).Range("A:E").EntireColumn.ClearContents
'Set the header
ThisWorkbook.Worksheets(aSpecies(i)).Range("A1:E1").Value = ThisWorkbook.Worksheets("data").Range("A1:E1").Value
Next i
End Sub
Sub CopyData()
Dim shtData As Worksheet
Set shtData = ThisWorkbook.Worksheets("data")
'Clear old data ans sets the header
ClearData shtData.Range("E2:E" & ThisWorkbook.Worksheets("data").Range("E2").End(xlDown).Row)
Dim i As Long, j As Long 'i = actual row in data sheet, j = new row in species sheet
i = 2
Do While shtData.Cells(i, 5) <> "" 'species
j = ThisWorkbook.Worksheets(CStr(shtData.Cells(i, 5))).Range("A1048576").End(xlUp).Offset(1, 0).Row
'this does the trick
ThisWorkbook.Worksheets(CStr(shtData.Cells(i, 5))).Range("A" & j & ":E" & j).Value = _
ThisWorkbook.Worksheets("data").Range("A" & i & ":E" & i).Value
i = i + 1
Loop
MsgBox "Done"
End Sub