Question

我知道这已被覆盖了很多次......我想知道在这种情况下我最好的选择是什么，代码更少，完成时间更短。

我在sheet1.Range（A1：A40）中列出了40个类别，其代码编号在sheet1.range（B1：B40）中。我需要滚动浏览B1：B40中的每个代码，寻找sheet2.range（A：A）中的匹配项，通常约为2000行。然后，我需要使用类别作为工作表名称将整行复制到第一行。

Sheet1中的值！A1是mysheet1
Sheet1中的值！B1是88888

我想循环遍历sheet2.range（“A：A”）上的2000行，寻找88888然后将整行复制到名为mysheet1的工作表中的第一个空白行

这里最好的方法是什么？我应该运行40个单独的过滤器宏并一次复制整个内容吗？我应该逐一查看sheet2中的每一行并复制它需要去的地方吗？我应该使用sheet1.range（“B1”）运行循环，复制所有匹配的值然后移动到下一个Sheet1.range（“B2”），依此类推？

我想我可以弄清楚如何做到这一点...只是想确保我使用最好和最快的方法。

Answer 1

好的，感谢上面的信息...我最终得到了这个有效的代码。希望我已经正确使用了这一切。

Dim myCat As String

Private Sub cmdInsertData_Click()
    Dim myCode As Long
    Dim destinationEmptyRow As Long
    Dim sourceLastRow As Long
    Dim myRow As Long
    Application.ScreenUpdating = False

    sourceLastRow = shDataHolder.Cells(10000, "A").End(xlUp).Row

    For Each cell In shDataHolder.Range("A1", "A" & sourceLastRow)
        myCode = Str(shDataHolder.Cells(cell.Row, 1))
        Call findCode(myCode)
        Call checkSheet(myCat)

        myRow = cell.Row
        destinationEmptyRow = Worksheets(myCat).Cells(1000, "A").End(xlUp).Row + 1

        shDataHolder.Rows(cell.Row & ":" & cell.Row).Copy
        Worksheets(myCat).Range("A" & destinationEmptyRow).PasteSpecial xlPasteAll
        Application.CutCopyMode = False

    Next cell
    Application.ScreenUpdating = True
End Sub

Private Sub findCode(code As Long)
    Dim storeLastRow As Long

    storeLastRow = shStores.Cells(100, "D").End(xlUp).Row
    For Each cell In shStores.Range("D5", "D" & storeLastRow)
        If cell = code Then
            myCat = shStores.Cells(cell.Row, 1)
            Exit For
        End If
    Next cell
End Sub

Private Sub checkSheet(cat As String)
    Dim ws As Worksheet
    Dim found As Boolean
        For Each ws In ActiveWorkbook.Worksheets
        If ws.Name = cat Then
            found = True
            Exit For
        End If
    Next ws
    If Not found Then
        Sheets.Add.Name = cat
    End If
End Sub

Answer 2

好的，既然你已经建议你可以弄清楚你的自我，我会sudo代码，但我发现这样的组合相当快，因为它会在找到值后立即退出。我使用这种方法复制远大于2000行的数据集，并且只需不到一分钟左右。

For Each cell in Sheet2.Range("A2","A" & last_row)
     category = get_category_by_code(Cells(cell.Row,2))
     find_or_create_sheet(category)
     Copy Entire Row
     last_row_in_sheet = Worksheets(category).Cells(1,"A").End(xlUp).Row + 1
     Paste Entire Row into last_row_in_sheet
Next cell

get_category_by_code(code)
   For Each cell in Sheet1.Range("B2","B" & last_row_sheet1)
       if cell = code then
          get_category_by_code = Cells(cell.Row,1)
          Exit For
       End
   next cell
End
find_or_create_sheet(cat)
   For Each ws in ActiveWorkbook.Sheets
       if ws.Name = cat then
          found = true
          Exit For
       end
   next ws 
   if not found then
      ActiveWorkbook.Sheets.Add cat
   end if
end

我可以提供实际代码，如果你想要它只需要一点时间，但概念是找到类别 - ＆gt;找到工作表或创建一个 - ＆gt;复制 - ＆gt;找到该表中的最后一行 - ＆gt;糊

修改添加了收集选项，但如果集合中不存在类别代码，则会将下标超出范围

Dim cat_coll AS New Collection For Each cell in Sheet1.Range("A2","A" & last_row) cat_coll.Add cell, Cells(cell.Row,2) Next cell For Each cell in Sheet2.Range("A2","A" & last_row) category = cat_coll.Items(cell) find_or_create_sheet(category) Copy Entire Row last_row_in_sheet = Worksheets(category).Cells(1,"A").End(xlUp).Row + 1 Paste Entire Row into last_row_in_sheet Next cell

最佳方法：遍历范围，根据结果进行复制（excel 2010）

2 个答案: