Question

我已经看过几篇关于这个问题的帖子，我仍在苦苦挣扎。我是VBA的新手，但很喜欢它。我的问题是这个我有一张32,000行的Excel表格。它是一个医疗保健提供商网超过200个国家的32,000家医疗保健提供商。我想做的是。让宏找到工作表1中的每个国家/地区，然后创建并命名新工作表，并仅使用此国家/地区的数据填充此新工作表。因此，它首先会找到阿富汗，填写第2页，其中包含有关阿富汗的第1页信息，然后创建一个新的表格，称为阿尔巴尼亚，并与阿尔巴尼亚一起填写表格3，直到津巴布韦

这是我到目前为止的代码

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方法会派上用场。

将唯一的国家/地区列表放在单元格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

Answer 2

我喜欢使用'自动过滤'方法的Scott Holtzman过滤技术

既然你要处理很多行，我认为测试替代行可能会有所帮助

这就是为什么，以及斯科特代码中的一些“化妆品”，您可能想尝试以下代码

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”）和我的（反过来！）

使用VBA

2 个答案: