Question

我想通过if then else函数创建一个宏（也许利用循环）。

我有两个单独的文件，分别是“ orderregistratie”和“ werkorder模板”。我想在orderregistratie中的sheets（“ datablad”）的A列中搜索值列表（“ export datablad”）。在werkorder模板中的范围（“ A2”）。

如果此值存在于A列中，则从导出数据刀片复制A2的行并将其粘贴到找到该值的行中。如果尚不存在，我想在orderregistratie的A2处插入新行，并从导出数据中复制A2的行到新行中。

我的VBA知识不是真的很好，我不能自己编写宏。有没有人可以帮助我写这本书？

Answer 1

尝试一下。我会根据需要进行调整。只需仔细检查两个工作簿是否都保存到您的桌面即可。

Option Explicit

Private wkbOrderReg     As Workbook, _
        wkbOrderWork    As Workbook, _
        wkb             As Workbook

Private wsOBJ           As Worksheet, _
        ws              As Worksheet

Private rngSearch       As Range, _
        rngRow          As Range, _
        rng             As Range, _
        r               As Range

Private strSearch       As String

Public Sub DarudeSandStorm()
    Dim LastRow     As Long, _
        LastColumn  As Long
    Dim arr         As Variant
    With Application.Workbooks
        Set wkbOrderReg = .Open(Filename:=strVar("orderregistratie.xlsx"))
        Set wkbOrderWork = .Open(Filename:=strVar("werkorder template.xlsx"))
    End With
    With wkbOrderWork
        For Each ws In .Worksheets
            Set wsOBJ = ws
            If UCase$(wsOBJ.Name) = UCase$("export datablad") Then
                    With wsOBJ
                    Set rng = .Range(.Cells(2, 1), .Cells(2, 1))
                        strSearch = rng.Value
                        LastColumn = getLAST_COLUMN(wsOBJ)
                    Set rngRow = .Range(.Cells(2, 1), .Cells(2, LastColumn))
                    End With
                        arr = rngRow
                Exit For
            End If
        Next ws
    End With
    With wkbOrderReg
        For Each ws In .Worksheets
            Set wsOBJ = ws
            If UCase$(wsOBJ.Name) = UCase$("export datablad") Then
                With wsOBJ
                    LastRow = getLAST_ROW(wsOBJ)
                Set rngSearch = .Range(.Cells(1, 1), .Cells(LastRow, 1))
                End With
                For Each r In rngSearch
                    If UCase$(r.Value) = UCase$(strSearch) Then
                        r = arr
                    End If
                Next r
            End If
        Next ws
    End With
    With Application
        For Each wkb In .Workbooks
            If Not wkb = .ThisWorkbook Then
                With .Workbooks(wkb.Name)
                    .Save
                    .Close
                End With
            End If
        Next wkb
    End With
End Sub

Private Function getLAST_COLUMN(objWS As Worksheet) As Long
    Dim wsDES               As Worksheet, _
        wkbSUB              As Workbook, _
        rngCHECK            As Range
    Set rngCHECK = objWS.Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookIn:=xlFormulas, _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False, _
                    SearchFormat:=False)
    If Not rngCHECK Is Nothing Then
        getLAST_COLUMN = objWS.Cells.Find("*", _
                    Range("A1"), _
                    xlFormulas, _
                    , _
                    xlByColumns, _
                    xlPrevious).Column
    Else
        getLAST_COLUMN = 1
    End If
End Function

Private Function getLAST_ROW(objWS As Worksheet) As Long
    Dim wsDES               As Worksheet, _
        wkbSUB              As Workbook, _
        rngCHECK            As Range
    Set rngCHECK = objWS.Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookIn:=xlFormulas, _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False, _
                    SearchFormat:=False)
    If Not rngCHECK Is Nothing Then
        getLAST_ROW = objWS.Cells.Find("*", _
                    Range("A1"), _
                    xlFormulas, _
                    , _
                    xlByRows, _
                    xlPrevious).Row
    Else
        getLAST_ROW = 1
    End If
End Function

Private Function strVar(ByRef str As String) As String
    strVar = Environ("Userprofile") & "\Desktop\" & str
End Function

Answer 2

@Mischa Urlings在此示例中，我已经将两个工作簿（“ orderregistratie” +“ werkorder模板”）保存在桌面上，因此您必须在代码上更改它们的路径。

Option Explicit

Sub test()

    Dim WbO As Workbook
    Dim WbW As Workbook

    Dim i As Long
    Dim LRA As Long
    Dim RowToCopy As Long
    Dim Rowstr As Long

    Dim Searchstr As String
    Dim Address As Range
    Dim Searchrng As Range

    Workbooks.Open Filename:="C:\Users\xxxx\Desktop\" & "orderregistratie.xlsx" '<= Open Workbooks (for this example files are stored on desktop
    Workbooks.Open Filename:="C:\Users\xxxx\Desktop\" & "werkorder template.xlsx"

    Set WbO = Workbooks("orderregistratie.xlsx") '<= Set workbook to variables
    Set WbW = Workbooks("werkorder template.xlsx")

    LRA = WbW.Worksheets("export datablad").Range("A" & Rows.Count).End(xlUp).Row '<= Find Lastrow

    For i = 2 To LRA '<= Loop column A (Workbook:werkorder template)
        Searchstr = WbW.Worksheets("export datablad").Range("A" & i).Value '<= Set what to search for
        Rowstr = i '<= Searchstr row
        Set Searchrng = WbO.Worksheets("datablad").Columns("A") '<= Set where to search for

        Set Address = Searchrng.Find(What:=Searchstr, LookAt:=xlWhole) '<= Result of the search

    If Address Is Nothing Then
        'If what we search for not found
        WbO.Worksheets("datablad").Rows("2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        WbW.Worksheets("export datablad").Rows(Rowstr).EntireRow.Copy
        WbO.Worksheets("datablad").Rows(2).PasteSpecial Paste:=xlPasteValues
    Else
        'If what we search for found
        RowToCopy = Address.Row '<= Where we find the Searchstr
        WbW.Worksheets("export datablad").Rows(i).EntireRow.Copy
        WbO.Worksheets("datablad").Rows(RowToCopy).PasteSpecial Paste:=xlPasteValues
    End If



    Next i

    With WbO
       .Save
       .Close '<= Close open workbooks
    End with
    With WbW  
       .Save
       .Close '<= Close open workbooks
    End with 

End Sub

Excel VBA如果值在列中则

2 个答案: