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

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

这是我到目前为止的代码

Sub RoundedRectangle2_Click()

Dim lastrow，erow尽可能长

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

---

使用

将非常感谢任何帮助。自动筛选
方法将派上用场

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

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

我喜欢使用“自动过滤”方法的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”子调用的注释，并对“FilterAndCopy 2”子调用进行注释）和我的过滤技术（做相反的操作！）
您需要向我们提供更多信息。你能给我举一个Excel文件中几行的例子吗？所有的国家都是手写的吗？为什么不是三个字母的ISO 3166-1 alpha-3标准国家代码？大家好，这里是我的专栏标题：Id称呼，名字Line1 Line2 Line3城市邮政编码国家/地区提供商类型Phone1 Tg第一状态Tg第二状态Tg第三状态电子邮件网站。这只是基本的联系方式。它持续了32000多条线路。国家在第10列这一列将决定何时创建新工作表以及将信息带到该工作表。谢谢你的帮助GUYSHi Scott谢谢你的帮助。不幸的是，我在rCL=wsCL.Range（“A1:A201”）处遇到运行时错误91。我的整个CountryList excel工作表是（“A1:Q32173”），国家列是（“J1:J32173）我希望这有帮助。@PhilipConnectell-错误已修复。请参阅编辑的代码。请确保遵循我回答中关于创建唯一国家/地区列表的第一点。再次感谢您的帮助运行编辑的代码获取编译错误：变量未定义：ws在Set rTest=ws.Range（“J1:J”&lRow）行上以蓝色突出显示。查找（rccountry.Value2，lookat:=xlWhole）。我将其更改为ws1.Range，这似乎有效。这样做正确吗？ws.Range（“A1:Q1”）。复制wsNew.Range（“A1”）一旦我编辑了这个部分，我得到了我们范围内的运行时错误99脚本。再次感谢您的时间和支持help@PhilipConnell-是的，他们应该阅读
ws1
，因为这是变量名（不是
ws
…为我没有编译而道歉）。您最后一次出现错误是在哪一行？不需要道歉。您帮了大忙。调试中没有突出显示任何内容，没有蓝色的内容，也没有黄色的内容。它只是说运行时错误脚本超出范围难以置信！！这非常有效。它正在做我需要的一切。非常感谢您的时间和帮助。Du非常尊敬您很高兴知道。也很好奇哪一个选项会更快。你两个都试过了吗？