VBA 调用时代码未正确执行

Question

大家好，希望对您有所帮助。我有一段代码见下文。

我想要实现的是用户打开一个包含命令按钮和说明的 Excel sheet。单击命令按钮后，将打开一个对话框，然后允许用户 select 另一个 excel sheet，一旦 excel sheet 是 selected 另一段代码（应该）触发并合并重复项并修改开始日期和结束日期，并且 sheet 在其所需状态下保持打开状态，没有重复项并且日期正确。

这段代码

Public Sub ConsolidateDupes()

当它本身是运行时工作完美，在原来的 sheet 上，但是当我尝试使用命令按钮调用它时，它无法正常工作。没有出现错误，它只是没有删除所有可能的重复项，并且没有将日期计算为最早的开始日期和最晚的结束日期

我添加了图片以便于解释图 1

Excel sheet 使用命令按钮

图 2 Sheet 将 select 编辑为原始状态，包含重复项和多个开始日期和结束日期

selected sheet 之后的代码已经运行被 itslef sheet

使用命令按钮时调用selected sheet

正如您所希望看到的那样，留下了重复项，并且日期未计算到最早的开始日期和最晚的结束日期

正如我所说，当 sheet 上的运行本身时，代码可以完美运行，但是当它被调用时，它会留下重复项并且无法在开始和结束日期工作

这是我的代码，我们一如既往地非常感谢您的帮助。

代码

Sub Open_Workbook_Dialog()

Dim my_FileName As Variant

    MsgBox "Select Denmark File" '<--| txt box for prompt to pick a file

        my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

    If my_FileName <> False Then
    Workbooks.Open Filename:=my_FileName


Call ConsolidateDupes   '<--|Calls the Filter Code and executes

End If


End Sub

Public Sub ConsolidateDupes()
    Dim wks As Worksheet
    Dim lastRow As Long
    Dim r As Long

    Set wks = Sheet1

    lastRow = wks.UsedRange.Rows.Count

    For r = lastRow To 3 Step -1
        ' Identify Duplicate
        If wks.Cells(r, 1) = wks.Cells(r - 1, 1) _
        And wks.Cells(r, 2) = wks.Cells(r - 1, 2) _
        And wks.Cells(r, 3) = wks.Cells(r - 1, 3) _
        And wks.Cells(r, 4) = wks.Cells(r - 1, 4) _
        And wks.Cells(r, 5) = wks.Cells(r - 1, 5) _
        And wks.Cells(r, 6) = wks.Cells(r - 1, 6) _
        And wks.Cells(r, 7) = wks.Cells(r - 1, 7) Then
            ' Update Start Date on Previous Row
            If wks.Cells(r, 8) < wks.Cells(r - 1, 8) Then
                wks.Cells(r - 1, 8) = wks.Cells(r, 8)
            End If
            ' Update End Date on Previous Row
            If wks.Cells(r, 9) > wks.Cells(r - 1, 9) Then
                wks.Cells(r - 1, 9) = wks.Cells(r, 9)
            End If
            ' Delete Duplicate
            Rows(r).Delete
        End If
    Next
End Sub

Answer 1

你能删除这个吗：

    Rows(r).Delete

改为这样写：

    wks.Rows(r).Delete

编辑：试试这个：（非常肮脏的解决方案，但它应该有效）

Sub Open_Workbook_Dialog()


    Dim strFileName     As string
    dim wkb             as workbook
    Dim wks             As Worksheet
    Dim lastRow         As Long
    Dim r               As Long

    MsgBox "Select Denmark File" '<--| txt box for prompt to pick a file

        strFileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

    set wkb = Application.Workbooks.Open(strFileName)
    Set wks = wkb.Sheet1
    lastRow = wks.UsedRange.Rows.Count

    For r = lastRow To 3 Step -1
        ' Identify Duplicate
        If wks.Cells(r, 1) = wks.Cells(r - 1, 1) _
        And wks.Cells(r, 2) = wks.Cells(r - 1, 2) _
        And wks.Cells(r, 3) = wks.Cells(r - 1, 3) _
        And wks.Cells(r, 4) = wks.Cells(r - 1, 4) _
        And wks.Cells(r, 5) = wks.Cells(r - 1, 5) _
        And wks.Cells(r, 6) = wks.Cells(r - 1, 6) _
        And wks.Cells(r, 7) = wks.Cells(r - 1, 7) Then
            ' Update Start Date on Previous Row
            If wks.Cells(r, 8) < wks.Cells(r - 1, 8) Then
                wks.Cells(r - 1, 8) = wks.Cells(r, 8)
            End If
            ' Update End Date on Previous Row
            If wks.Cells(r, 9) > wks.Cells(r - 1, 9) Then
                wks.Cells(r - 1, 9) = wks.Cells(r, 9)
            End If
            ' Delete Duplicate
            Rows(r).Delete
        End If
    Next
End Sub

但是，问题是它不起作用，因为您没有将 my_FileName 传递给 ConsolidateDupes 过程。这样，程序是在按钮所在的文件中执行的，在那里有点意义不大。

您好，所以需要进行一些更改才能使其正常工作，下面是有效的代码我希望它能帮助 VBA 的朋友 :-)

   Sub Open_Workbook_Dialog()


    Dim strFileName     As String
    Dim wkb             As Workbook
    Dim wks             As Worksheet
    Dim LastRow         As Long
    Dim r               As Long

    MsgBox "Select Denmark File" '<--| txt box for prompt to pick a file

        strFileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

    Set wkb = Application.Workbooks.Open(strFileName)
    Set wks = ActiveWorkbook.Sheets(1)
    LastRow = wks.UsedRange.Rows.Count

    ' Sort the B Column Alphabetically
    With ActiveWorkbook.Sheets(1)

        Dim LastRow2 As Long
        LastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
        Dim LastCol As Long
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        With ActiveWorkbook.Worksheets("Sheet1").Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range(Cells(2, 2), Cells(LastRow, 2)), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending, _
                            DataOption:=xlSortNormal
            .SetRange Range(Cells(2, 1), Cells(LastRow, LastCol))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply

        End With

    End With

    For r = LastRow To 3 Step -1
        ' Identify Duplicate
        If wks.Cells(r, 1) = wks.Cells(r - 1, 1) _
        And wks.Cells(r, 2) = wks.Cells(r - 1, 2) _
        And wks.Cells(r, 3) = wks.Cells(r - 1, 3) _
        And wks.Cells(r, 4) = wks.Cells(r - 1, 4) _
        And wks.Cells(r, 5) = wks.Cells(r - 1, 5) _
        And wks.Cells(r, 6) = wks.Cells(r - 1, 6) _
        And wks.Cells(r, 7) = wks.Cells(r - 1, 7) Then
           ' Update Start Date on Previous Row
        If CDate(wks.Cells(r, 8)) < CDate(wks.Cells(r - 1, 8)) Then
         wks.Cells(r - 1, 8) = wks.Cells(r, 8)
        End If
        ' Update End Date on Previous Row
        If CDate(wks.Cells(r, 9)) > CDate(wks.Cells(r - 1, 9)) Then
        wks.Cells(r - 1, 9) = wks.Cells(r, 9)
        End If
            ' Delete Duplicate
            Rows(r).Delete
        End If
    Next
End Sub

VBA 调用时代码未正确执行

VBA code not executing properly when called

excel

vba

call

duplicates