0

私は2つのファイルを持っています。ユーザーがマクロを実行したときに既に開いている最初のファイルには、5 つのワークシートがあります。各ワークシートには、異なる場所に「Order-Item」列が含まれています。ワークシートの例は次のようになります

-Date Time Order-item Order-Quanity 
-1020 9:30 item533333 (blank)
-1020 7:30 item733333 (blank)
-1020 2:30 item333332 (blank)
-1020 6:30 item121242 (blank)

マクロを実行した後、ユーザーは開くファイルを次のように選択します。

-Order-item Order-Quantity
-item121242 183
-item333332 515
-item533333 27
-item333332 761

次に、マクロは元のファイルのすべてのワークシートを調べます。各ワークシートで、order-item 列が配置されている場所を見つけてから、列の各項目を調べます。ユーザーが選択したファイルで注文項目 (通常は列 A) を検索し、数量を検索します (常に注文項目列の隣、この場合は列 B)。

元のワークシートを実行すると、次のようになります。

-Date Time Order-item Order-Quanity
-1020 9:30 item533333 27
-1020 7:30 item733333 515 
-1020 2:30 item333332 761
-1020 6:30 item121242 183

これを行うマクロを作成しましたが、両方のファイルがかなり大きいため (元のファイルには約 10,000 行あり、ユーザーが開いたファイルには最大 50,000 行あります)、マクロの実行に時間がかかります。Vlookup、filldown を実行してから値を貼り付けるだけで、はるかに高速になることがわかりました。ただし、これはより大きな自動化マクロの一部であり、これは現実的ではありません。コードをより効率的に、またはより速く実行するために誰かが提案できる改善点はありますか? もしそうなら、私に知らせてください。ありがとう！

Public Sub OpenFile()

Dim FilePath As Variant
Dim FileName As String
Dim CurrentWorkbook As String
Dim thisWB As Workbook
Dim openWB As Workbook
Dim sh As Worksheet
Dim lastRow As Long
Dim myRange As Range
Dim FoundCell As Range
Dim counter1 As Long
Dim counter2 As Long
Dim orderColumn As Long

Set thisWB = Application.ActiveWorkbook
CurrentWorkbook = Application.ActiveWorkbook.Name
FilePath = Application.GetOpenFilename(FileFilter:= _
            "Excel Workbook Files(*.xl*),*.xl*", MultiSelect:=False, Title:="Select File")
If Not FilePath = False Then
    FileName = FilePath
    Set openWB = Application.Workbooks.Open(FileName)
    FileName = Mid(FileName, InStrRev(FileName, "\") + 1, Len(FileName)) 'extracts filename from path+filename
Else
    MsgBox ("File not selected or selected file not valid")
    Exit Sub
End If
Application.Workbooks(FileName).Activate
'--------------------------------------------------------------------------------------------------
'--------------gets table range from input box.  Defailt is Row A,B--------------------------------
'--------------------------------------------------------------------------------------------------
Set myRange = Application.InputBox( _
    "Select Table Range.  First Column should be Order-item, Second Column should be Order Grade", _
    "Select Range", "$A:$B", , , , , 8)
On Error GoTo 0
'for every worksheet in currentworkbook, find how many rows there are.and find location of _
order-item. then go through each row in the order-item column and compare to column A(order-item) _
on the user selected workbook.  if match is found, place column B into order-item column+1
Application.ScreenUpdating = False
For Each sh In thisWB.Worksheets
    lastRow = LastRowUsed(sh)
    'Find Order Column
    Set FoundCell = sh.Rows(1).Find(what:="Order-Item", LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    If Not FoundCell Is Nothing Then
        orderColumn = FoundCell.Column
    Else
        MsgBox ("Couldn't find ""Order-Item"" in Header, exiting macro")
        Exit Sub
    End If

    For counter1 = lastRow To 1 Step -1
        For counter2 = myRange.Rows.Count To 1 Step -1
        If sh.Cells(counter1, orderColumn) = myRange.Cells(counter2, 1).Value Then
            sh.Cells(counter1, orderColumn + 1) = myRange.Cells(counter2, 2)
            Exit For
        End If
        Next
    Next
Next
Application.ScreenUpdating = True
End Sub
4

2 に答える 2

0

編集: 重複した ID を処理するように更新されました。

Sub Tester()
    UpdateFromSelection Workbooks("Book3").Sheets("Sheet1").Range("A1:B21")
End Sub

Sub UpdateFromSelection(myRange As Range)
    Dim d, rw As Range, tmp, c As Range, arr, i

    Set d = GetItemMap()

    If d Is Nothing Then Exit Sub
    Debug.Print d.Count
    If d.Count = 0 Then
        MsgBox "nothing found!"
        Exit Sub
    End If

    For Each rw In myRange.Rows
        tmp = rw.Cells(1).Value
        If Len(tmp) > 0 Then
        If d.exists(tmp) Then
            arr = d(tmp)
            For i = LBound(arr) To UBound(arr)
                arr(i).Value = rw.Cells(2).Value
            Next i
        End If
        End If
    Next rw

End Sub

Function GetItemMap() As Object
Dim dict As Object, ws As Worksheet
Dim f As Range, lastRow As Long, tmp, arr, ub As Long

    Set dict = CreateObject("scripting.dictionary")
    For Each ws In ThisWorkbook.Worksheets
        Set f = ws.Rows(1).Find(what:="Order-Item", LookIn:=xlValues, _
                                LookAt:=xlWhole)
        If Not f Is Nothing Then
            Set f = f.Offset(1, 0)
            lastRow = ws.Cells(Rows.Count, f.Column).End(xlUp).Row
            Do While f.Row <= lastRow
                tmp = Trim(f.Value)
                If Len(tmp) > 0 Then
                    If Not dict.exists(tmp) Then
                        dict.Add tmp, Array(f.Offset(0, 1))
                    Else
                        'can same item# exist > once?
                        arr = dict(tmp)
                        ub = UBound(arr) + 1
                        ReDim Preserve arr(0 To ub)
                        Set arr(ub) = f.Offset(0, 1)
                        dict(tmp) = arr
                    End If
                End If
                Set f = f.Offset(1, 0)
            Loop
        Else
            MsgBox ("Couldn't find 'Order-Item' in Header!")
            Exit Function
        End If
    Next ws

    Set GetItemMap = dict
End Function
于 2013-10-27T21:07:08.957 に答える