vba查找值，然后将另一个粘贴到另一列的不同单元格中 [英] vba find value then paste another into different cell in another column

问题描述

我当前正在运行一个宏，该宏在工作表2的C列中从工作表1"的A列中查找值，如果这些匹配，则应将工作表1的B列中的值复制到工作表2中的相应行.

我拥有的宏有效，但是由于这是一个庞大的工作表，因此其中的循环花费了太多时间.这是因为工作表1大约有300,000行，并且每个实例中的值都是唯一的.在工作表2中，大约有50,000行.它一直运行一整夜，到目前为止在工作表1中仅达到60,000行

我绝不是VBA专家，甚至不是中级专家，但从我阅读的内容来看，也许使用查找比查找匹配和循环要快?

这是我当前正在使用的宏

 Option Explicit

Sub lookupandcopy()
Application.Screenupdating = True

Dim j As Long, i As Long, lastRow1 As Long, lastRow2 As Long
Dim sh_1, sh_3 As Worksheet
Dim MyName As String

Set sh_1 = Sheets("sheet1") 
Set sh_3 = Sheets("sheet2")


lastRow1 = sh_1.UsedRange.Rows.Count 

For j = 2 To lastRow1
MyName = sh_1.Cells(j, 1).Value 


lastRow2 = sh_3.UsedRange.Rows.Count

For i = 2 To lastRow2
    If sh_3.Cells(i, 3).Value = MyName Then
        sh_3.Cells(i, 13).Value = sh_1.Cells(j, 2).Value 
    End If

    Next i

  Next j

Application.Screenupdating = True
End Sub

如果我错过了任何其他事项或需要的其他详细信息，请告诉我！

解决方案

您似乎正在使用sheet1中的A列和B列作为字典(并通过线性搜索访问值).为什么不将值加载到具有O(1)搜索的字典对象中?确保您的项目中包含对Microsoft脚本运行时的引用(如果您还没有这样做，则在VBE中使用工具">引用")，然后尝试:

Sub lookupandcopy()
    Application.ScreenUpdating = False

    Dim AVals As New Dictionary
    Dim i As Long, j As Long, lastRow1 As Long, lastRow2 As Long
    Dim sh_1, sh_3 As Worksheet
    Dim MyName As String

    Set sh_1 = Sheets("sheet1")
    Set sh_3 = Sheets("sheet2")

    With sh_1
        lastRow1 = .Range("A:A").Rows.Count 'last row in spreadsheet
        lastRow1 = .Cells(lastRow1, 1).End(xlUp).Row 'last used row in column A
        'load the AVal dict
        For j = 2 To lastRow1
            MyName = .Cells(j, 1).Value
            If Len(MyName) > 0 Then AVals.Add MyName, .Cells(j, 2).Value
        Next j
    End With

    With sh_3
        lastRow2 = .Range("A:A").Rows.Count
        lastRow2 = .Cells(lastRow2, 3).End(xlUp).Row 'last used row in column 3
        For i = 2 To lastRow2
            MyName = .Cells(i, 3).Value
            If AVals.Exists(MyName) Then
                .Cells(i, 13).Value = AVals.Item(MyName)
            End If
         Next i
    End With
    Application.ScreenUpdating = True
End Sub

如果在A列中有重复的值，则需要执行类似将值存储在其中的行索引存储为值的集合之类的操作，但是设置此类字典的工作仍然比使用嵌套循环更好. /p>

I'm currently running a Macro that looks for a value from column A of 'sheet 1' in column C of sheet 2, if these match then the value from column B of sheet 1 should be copied to column M of the corresponding row in sheet 2.

The Macro I have works, but because this is a massive worksheet, the loop in it is taking far too much time. This is because sheet 1 has around 300,000 rows and the value in each instance is unique. in Sheet 2 there are around 50,000 rows. It's been running overnight and has only reached 60,000 rows in sheet 1 so far

I'm by no means a VBA expert, or even intermediate but from what I've read maybe using Find would be faster than looking for a match and looping?

this is the macro i'm currently using

 Option Explicit

Sub lookupandcopy()
Application.Screenupdating = True

Dim j As Long, i As Long, lastRow1 As Long, lastRow2 As Long
Dim sh_1, sh_3 As Worksheet
Dim MyName As String

Set sh_1 = Sheets("sheet1") 
Set sh_3 = Sheets("sheet2")


lastRow1 = sh_1.UsedRange.Rows.Count 

For j = 2 To lastRow1
MyName = sh_1.Cells(j, 1).Value 


lastRow2 = sh_3.UsedRange.Rows.Count

For i = 2 To lastRow2
    If sh_3.Cells(i, 3).Value = MyName Then
        sh_3.Cells(i, 13).Value = sh_1.Cells(j, 2).Value 
    End If

    Next i

  Next j

Application.Screenupdating = True
End Sub

If I've missed anything off or any other detail that's needed please let me know!

解决方案

You seem to be using columns A and B in sheet1 as a dictionary (and accessing the values by a linear search). Why not load the values into a dictionary objects which has O(1) search? Make sure that your project includes a reference to Microsoft Scripting Runtime (tools > references in the VBE if you haven't done such things) then try:

Sub lookupandcopy()
    Application.ScreenUpdating = False

    Dim AVals As New Dictionary
    Dim i As Long, j As Long, lastRow1 As Long, lastRow2 As Long
    Dim sh_1, sh_3 As Worksheet
    Dim MyName As String

    Set sh_1 = Sheets("sheet1")
    Set sh_3 = Sheets("sheet2")

    With sh_1
        lastRow1 = .Range("A:A").Rows.Count 'last row in spreadsheet
        lastRow1 = .Cells(lastRow1, 1).End(xlUp).Row 'last used row in column A
        'load the AVal dict
        For j = 2 To lastRow1
            MyName = .Cells(j, 1).Value
            If Len(MyName) > 0 Then AVals.Add MyName, .Cells(j, 2).Value
        Next j
    End With

    With sh_3
        lastRow2 = .Range("A:A").Rows.Count
        lastRow2 = .Cells(lastRow2, 3).End(xlUp).Row 'last used row in column 3
        For i = 2 To lastRow2
            MyName = .Cells(i, 3).Value
            If AVals.Exists(MyName) Then
                .Cells(i, 13).Value = AVals.Item(MyName)
            End If
         Next i
    End With
    Application.ScreenUpdating = True
End Sub

If you have repeated values in column A then you would need to do something like store as values collections of row indices where the value occurs, but the effort of setting up such a dictionary would still be better than using nested loops.

这篇关于vba查找值，然后将另一个粘贴到另一列的不同单元格中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！