Question

我希望你能提供帮助。

我有一段很长的代码， CODE 2 这样做是为了让用户打开一个对话框，选择一张纸，一旦选择了一张纸就会格式化纸张，过滤第7列然后添加新工作表，其中包含来自第7列的复制信息，为工作表命名，再次格式化，添加和删除列，减去日期和返回数字，我基本上最终得到了您在 Pic 1 中看到的内容（更多的是发生，但这是它的要点）我很满意 CODE 2

如果用户在A2中选择的值不是＆＃34;在此输入您的国家＆＃34; ，那么我现在还有 CODE 1 ＆＃34;在此处输入您的国家＆＃34; 在工作簿中被替换为A2中的新值。

CODE 1 也可以正常使用

问题是我似乎无法将 CODE 1 加入 CODE 2 。 CODE 1 本身就能很好地工作但是我似乎无法将其称之为或者在我放置的位置触发它或在 CODE 2

中调用它

可以 CODE 1 加入 CODE 2 ，以便当用户选择找到的国家/地区并替换＆＃34;在此处输入您的国家＆＃34 ; ，带有A2中的选定值

就像说两个代码分别工作得很好我只需要把1加到2中一些如何

一如既往，我们非常感谢所有人的帮助。

图1

代码1

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range

    ' The variable KeyCells contains the cells that will
    ' cause an alert when they are changed.
    Set KeyCells = Range("A2")

    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then

        ' Display a message when one of the designated cells has been
        ' changed.
        ' Place your code here.
        Call Find_Replace

    End If
End Sub

Public Sub Find_Replace()

Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant

fnd = "Enter Your Country Here"
rplc = Worksheets("SearchCasesResults").Range("A2").Value

For Each sht In ActiveWorkbook.Worksheets
  sht.Cells.Replace what:=fnd, Replacement:=rplc, _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
    SearchFormat:=False, ReplaceFormat:=False
Next sht

End Sub

CODE 2

Sub Open_Workbook_Dialog()

Dim my_FileName As Variant

    MsgBox "Pick your Disputes 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 Sort_Disputes   '<--|Calls Sort Disputes and begins to format

End If


End Sub

Public Sub Sort_Disputes()

With ActiveWorkbook.Sheets(1)

Rows("1:5").Delete '<--|Deletes the first 5 rows
Range("A1").EntireColumn.Insert '<--|Inserts a new A column
Range("A1").Value = "Market" '<--|Market text enters cell A1
Cells(1, 2).Copy
Cells(1, 1).PasteSpecial (xlPasteFormats) '<--|Keeps the formatting of other columns and forces to new column A
Application.CutCopyMode = False
Columns.AutoFit '<--|Auto fits the columns
Range("C:C,J:J,M:AF").EntireColumn.Delete '<--|Deletes Columns
Rows("2:2500").RowHeight = 25 '<--|Adjusts Row Height

Call populateA '<--|Calls PopulateA and this takes a look a Column A and where blank enters text

End With


Call Filter '<--|Calls Filter which looks down the 7th Column and seperates out the sheets to new tabs based on the value in Column 7

Call Activate_Sheet '<--|Deletes a column then subtracts todays date from the date in C and represents as a number in D

Call Activate_Sheet_2 '<--|As long as C is not blank it will subtract the Date in C from the Date in D and return a numerical result

Call Add_Sheet

End Sub

Public Sub Filter()
    Dim rCountry As Range, helpCol As Range

    With ActiveWorkbook.Sheets(1) '<--| refer to data worksheet
        With .UsedRange
            Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in
        End With

        With .Range("A1:Q" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Q" from row 1 to last non empty row of column "A"
            .Columns(7).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 7th column of the referenced range and store its unique values in "helper" column
            Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row)
            For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row)
                .AutoFilter 7, rCountry.Value2 '<--| filter data on country field (7th column) with current unique country name
                If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered...
                    Worksheets.Add Worksheets(Worksheets.Count) '<--... add new sheet
                    ActiveSheet.Name = rCountry.Value2  '<--... rename it
                    .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header
                End If
            Next
        End With
        .AutoFilterMode = False '<--| remove autofilter and show all rows back
    End With
    helpCol.Offset(-1).End(xlDown).EntireColumn.Delete '<--| clear helper column (header included)


End Sub

Public Sub populateA()

Dim WS As Worksheet
    Dim lRow As Long

    Set WS = ActiveWorkbook.Sheets(1)

    With WS
        lRow = .Range("B" & .Rows.Count).End(xlUp).Row '<--| Looks for the last empty cell in Column B

        .Range("A2:A" & lRow).Formula = "=If(B2<>"""",""Enter Your Country Here"","""")" '<--| If there is no blank cell in B and A has a blank cell then A gets populated with "Enter your Country Here"
        .Range("A2:A" & lRow).Value = .Range("A2:A" & lRow).Value
        .Range("A2:A" & lRow).Interior.ColorIndex = 39 '<--|Changes the colour of A
    End With

End Sub

Public Sub Activate_Sheet()

Worksheets("In Progress").Activate '<--|Activates Inprogress Sheet
Columns.AutoFit '<--|Auto fits Columns
Range("N:N").EntireColumn.Delete '<--|Delete Columns
Range("D1").Value = "# days open" '<--|Enters Value
Rows("2:2500").RowHeight = 25 '<--|Adjusts Row Height

Dim LastRow  As Long, i As Long
With Worksheets("In Progress")
    LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row '<--|Looks for the last non empty cell in C

    For i = 2 To LastRow
        .Range("D" & i).Value = DateDiff("d", .Range("C" & i).Value, Date) '<--|As long as C is not blank it will subtract todays date from C and populate in D
    Next i
End With

End Sub

Public Sub Activate_Sheet_2()

Worksheets("Complete").Activate '<--|Activates Complete Sheet
Columns.AutoFit '<--|Auto fits Columns
Range("N:N").EntireColumn.Delete '<--|Deletes Columns
Range("E1").EntireColumn.Insert '<--|Inserts Columns
Range("E1").Value = "Overall Ticket Aging" '<--|Enters Value
Rows("2:2500").RowHeight = 25 '<--|Adjusts Row Height

Dim LastRow  As Long, i As Long
With Worksheets("Complete")
    LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

    For i = 2 To LastRow
        .Range("E" & i).Value = DateDiff("d", .Range("C" & i).Value, .Range("D" & i).Value) '<--|As long as C is not blank it will subtract the Date in C from the Date in D and return a numerical result
    Next i
End With
Columns(5).NumberFormat = "0" '<--|Formats the 5 column to number format
End Sub

Public Sub Add_Sheet()
''Dim WS As Worksheet
''Set WS = Sheets.Add
Sheets.Add.Name = "Countries"
Worksheets("Countries").Activate
Range("A1").Value = "Country"
Range("A2").Value = "UK"
Range("A3").Value = "Belgium"
Range("A4").Value = "Bulgaria"
Range("A5").Value = "Croatia"
Range("A6").Value = "Czech Republic"
Range("A7").Value = "Slovenia"
Range("A8").Value = "Spain"
Range("A9").Value = "Italy"
Range("A10").Value = "Germany"
Worksheets("SearchCasesResults").Activate

Call Auto_Filter
End Sub

Public Sub Auto_Filter()

'replace "J2" with the cell you want to insert the drop down list
With Range("A2").Validation
.Delete
'replace "=A2:A6" with the range the data is in.
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=Countries!A2:A10"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With

End Sub

要解决此问题，我需要将更改事件VBA代码放入另一个工作表的VBA代码。调用我所拥有的代码并不起作用，因为我正在调用一个没有意义的变更事件。我需要代码将更改事件放入工作表中。

我用来将更改事件的代码放入我的示例中的工作表中，该工作表名为＆＃34; SearchCasesResults＆＃34;在下面我希望它可以帮助某人。

将代码放入另一张表的代码

Public Sub CreateEventProcedure()
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.CodeModule
        Dim LineNum As Long
        Const DQUOTE = """" ' one " character
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents("Sheet1")
        Set CodeMod = VBComp.CodeModule

        With CodeMod
            LineNum = .CreateEventProc("Change", "Worksheet")
            LineNum = LineNum + 1
            ''.InsertLines LineNum, "    MsgBox " & DQUOTE & "Hello World" & DQUOTE
            ''.InsertLines LineNum, "  Cells.Columns.AutoFit"
            ''.InsertLines LineNum, "  End Sub"
            .InsertLines LineNum, "  Worksheets(" & DQUOTE & "SearchCasesResults" & DQUOTE & ").Activate"
            .InsertLines LineNum, "  Next sht"
            .InsertLines LineNum, "  SearchFormat:=False, ReplaceFormat:=False"
            .InsertLines LineNum, "  LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _"
            .InsertLines LineNum, "  sht.Cells.Replace what:=fnd, Replacement:=rplc, _"
            .InsertLines LineNum, "  For Each sht In ActiveWorkbook.Worksheets"
            .InsertLines LineNum, "  rplc = Worksheets(" & DQUOTE & "SearchCasesResults" & DQUOTE & ").Range(" & DQUOTE & "A2" & DQUOTE & ").Value"
            .InsertLines LineNum, "  fnd = " & DQUOTE & "Enter Your Country Here" & DQUOTE & ""
            .InsertLines LineNum, "  Dim rplc As Variant"
            .InsertLines LineNum, "  Dim fnd As Variant"
            .InsertLines LineNum, "  Dim sht As Worksheet"


        End With
End Sub

VBA更改单元格值以运行另一个宏

0 个答案: