调用时 VBA 代码无法正确执行

Question

大家好，希望能帮到你。我有一段代码见下文。

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

一段代码

Public Sub ConsolidateDupes()

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

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

带有命令按钮的 Excel 工作表

图 2 以原始状态选择的工作表，带有重复项和多个开始和结束日期

代码在该工作表上运行后选定的工作表

使用命令按钮时调用时选择的工作表

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

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

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

代码

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