使用 VBA 将数据从主工作表传输到基于列的多个

Question

我已经看过一些关于这个问题的帖子，但我仍在苦苦挣扎。我是 VBA 的新手，但很喜欢它。我的问题是这个 我有一个 32,000 + 行的 Excel 表。它是一个医疗保健提供者网络。 200 多个国家/地区的 32,000 家医疗保健提供者。我想做的是。让宏在工作表 1 中找到每个国家/地区，然后创建并命名一个新工作表，并仅使用该国家/地区的数据填充此新工作表。所以它首先会找到阿富汗，用第一张关于阿富汗的信息填充第二张，然后创建一个名为阿尔巴尼亚的新表格，然后用阿尔巴尼亚填充第三张，依此类推，直到津巴布韦

这是我到目前为止的代码

Sub RoundedRectangle2_Click()

Dim lastrow, erow As Long

lastrow = ThisWorkbook.Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Sheet1.Cells(i, 7) = "Ireland" Then
Sheet1.Cells(i, 1).Copy

erow = ThisWorkbook.Worksheets("sheet2").Cells(Rows.Count,
1).End(xlUp).Offset(1, 0).Row
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 1)
Sheet1.Cells(i, 2).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 2)
Sheet1.Cells(i, 3).Cop
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 3)
Sheet1.Cells(i, 4).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 4)
Sheet1.Cells(i, 5).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 5)
Sheet1.Cells(i, 6).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 6)
Sheet1.Cells(i, 7).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 7)
Sheet1.Cells(i, 8).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 8)
Sheet1.Cells(i, 9).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 9)
Sheet1.Cells(i, 10).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 10)
Sheet1.Cells(i, 11).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 11)
Sheet1.Cells(i, 12).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 12)
Sheet1.Cells(i, 13).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 13)
Sheet1.Cells(i, 14).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 14)
Sheet1.Cells(i, 15).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 15)
End If
Next i
Application.CutCopyMode = False
ThisWorkbook.Worksheets("sheet2").Columns().AutoFit
Range("A1").Select
End Sub

我们将不胜感激任何帮助

Answer 1

使用.AutoFilter 方法会派上用场。

将唯一的国家/地区列表放在名为 CountryList 的工作表上的单元格 A1:A201 中，然后尝试以下代码。我从您问题中的代码中推测了您的实际范围引用，但如果需要，请进行调整。

Option Explicit

Sub Filter()

Dim wsCL As Worksheet
Set wsCL = Worksheets("CountryList")

Dim rCL As Range, rCountry As Range
Set rCL = wsCL.Range("A1:A201")

Dim ws1 As Worksheet
Set ws1 = Worksheets("Sheet1")

Dim lRow As Long
lRow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row

For Each rCountry In rCL

    'check if country exists
    Dim rTest As Range
    Set rTest = ws1.Range("J1:J" & lRow).Find(rCountry.Value2, lookat:=xlWhole)

    If Not rTest Is Nothing Then 'if country is found create sheet and copy data

        Dim wsNew As Worksheet
        Worksheets.Add (ThisWorkbook.Worksheets.Count)
        Set wsNew = ActiveSheet
        wsNew.Name = rCountry.Value2
        ws1.Range("A1:Q1").Copy wsNew.Range("A1") 'place header row

        With ws1.Range("A1:Q" & lRow)
            .AutoFilter 10, rCountry.Value2
            .Offset(1).SpecialCells(xlCellTypeVisible).Copy wsNew.Range("B1") 'copy data for country under header
            .AutoFilter
        End With

    End If

Next

End Sub

Answer 2

我喜欢使用“Autofilter”方法的 Scott Holtzman 过滤技术

而且由于您要处理很多行，我认为测试替代行可能会有所帮助

这就是为什么，连同 Scott 代码中的一些“化妆品”，您可能想尝试以下代码

Option Explicit

Sub RoundedRectangle2_Click()
Dim lastRow
Dim baseSheet As Worksheet, newSht As Worksheet
Dim searchedRng As Range, dataRng As Range, headerRng As Range
Dim cell As Range
Dim processedCountries As String, country As String

Application.ScreenUpdating = False

Set baseSheet = ThisWorkbook.Worksheets("Sheet1") ' this is the sheet where all data resides
With baseSheet
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).row
    Set searchedRng = .Range("J2:J" & lastRow)
    Set dataRng = .Range("A1:Q" & lastRow)
    Set headerRng = .Range("A1:Q1")

    For Each cell In searchedRng
        country = cell.Value
        If InStr(processedCountries, "-" & country & "-") = 0 Then ' check if the country has already been processd

            ' set the 'Country' sheet
            Set newSht = setNewSheet(ThisWorkbook, country, headerRng)

            ' filter and copy values to the 'Country' sheet
'            Call FilterAndCopy(dataRng, country, newSht) ' option 1
            Call FilterAndCopy2(headerRng, searchedRng, dataRng, country, newSht) ' option 2

            processedCountries = processedCountries & "-" & country & "-" ' update processed countries string

        End If
    Next cell
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub


Sub FilterAndCopy(rangeToFilter As Range, filterValue As String, sheetToPasteTo As Worksheet)

With rangeToFilter
    .AutoFilter 10, filterValue
    .Offset(1).Resize(rangeToFilter.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy sheetToPasteTo.Range("A2") 'copy data for filterValue under header
    .AutoFilter
End With
sheetToPasteTo.Columns().AutoFit

End Sub

Sub FilterAndCopy2(headerRng As Range, searchedRng As Range, rangeToFilter As Range, filterValue As String, sheetToPasteTo As Worksheet)
Dim cell As Range
Dim rangeToCopy As Range

Set rangeToCopy = headerRng
For Each cell In searchedRng
    If cell.Value = filterValue Then Set rangeToCopy = Union(rangeToCopy, rangeToFilter.Offset(cell.row - 1).Resize(1))
Next cell
rangeToCopy.Copy sheetToPasteTo.Range("A1") 'copy data for filterValue under header
sheetToPasteTo.Columns().AutoFit

End Sub


Function setNewSheet(myWorkBook As Workbook, shtName As String, Optional headerRng As Variant) As Worksheet

On Error Resume Next
Set setNewSheet = myWorkBook.Worksheets(shtName)
On Error GoTo 0

If setNewSheet Is Nothing Then
    myWorkBook.Worksheets.Add

    Set setNewSheet = ActiveSheet
    setNewSheet.Name = shtName
Else
    setNewSheet.Cells.ClearContents
End If

If Not IsMissing(headerRng) Then headerRng.Copy setNewSheet.Range("A1")

End Function

您可以尝试测试 Scott 的过滤技术（选项 1 -> 取消注释“FilterAndCopy”子调用并注释“FilterAndCopy2”）和我的过滤技术（相反！）