Question

我目前有一个宏，它遍历我的主电子表格中的一列，然后导出所有在开始时输入的值与列中的值匹配的行。然后它将新工作表保存为值。这是我目前的代码：

  Option Explicit

Public Const l_HeaderRow As Long = 2 'The header row of the data sheet
Public Const l_DistanceCol As Long = 5 'The column containing the distance values

Public Sub ExportDistance()
Dim ws_Data As Worksheet, wb_Export As Workbook, ws_Export As Worksheet
Dim l_InputRow As Long, l_OutputRow As Long
Dim l_LastCol As Long
Dim l_NumberOfMatches As Long
Dim s_Distance As String, l_Distance As Long
Dim s_ExportPath As String, s_ExportFile As String, s_PathDelimiter As String

    Set ws_Data = ActiveSheet

    s_Distance = InputBox("Enter Distance to Export to New File", "Enter Distance")
    If s_Distance = "" Then Exit Sub
    l_Distance = CLng(s_Distance)
    l_NumberOfMatches = WorksheetFunction.Match(l_Distance, ws_Data.Columns(5), 0)
    If l_NumberOfMatches <= 0 Then Exit Sub

    'Application.ScreenUpdating = False
    'Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    On Error Resume Next
    Call Application.Workbooks.Add
    Set wb_Export = Application.Workbooks(Application.Workbooks.Count)
    Set ws_Export = wb_Export.Worksheets(1)
    Call wb_Export.Worksheets("Sheet2").Delete
    Call wb_Export.Worksheets("Sheet3").Delete
    Application.DisplayAlerts = True
    ws_Export.Name = GetNextSheetname(ws_Data.Name & "-" & s_Distance, wb_Export)

    Call ws_Data.Rows(1).Resize(l_HeaderRow).Copy
    Call ws_Export.Rows(1).Resize(l_HeaderRow).Select
    Call ws_Export.Paste

    l_OutputRow = l_HeaderRow + 1
    l_LastCol = ws_Data.UsedRange.Columns.Count
    For l_InputRow = l_HeaderRow + 1 To ws_Data.UsedRange.Rows.Count
        If ws_Data.Cells(l_InputRow, l_DistanceCol).Value = l_Distance Then

            Call ws_Data.Range(ws_Data.Cells(l_InputRow, 1), ws_Data.Cells(l_InputRow, l_LastCol)).Copy
            Call ws_Export.Rows(l_OutputRow).Select
            Call ws_Export.Paste

            l_OutputRow = l_OutputRow + 1
        ElseIf ws_Data.Cells(l_InputRow, l_DistanceCol).Value = l_Distance Then

            Call ws_Data.Range(ws_Data.Cells(l_InputRow, 1), ws_Data.Cells(l_InputRow, l_LastCol)).Copy
            Call ws_Export.Rows(l_OutputRow).Select
            Call ws_Export.Paste

            l_OutputRow = l_OutputRow + 1
        End If

    Next l_InputRow

    s_ExportPath = ThisWorkbook.Path
    s_PathDelimiter = Application.PathSeparator
    If Right(s_ExportPath, 1) <> s_PathDelimiter Then s_ExportPath = s_ExportPath & s_PathDelimiter
    s_ExportPath = s_ExportPath & "Output" & s_PathDelimiter
    If Dir(s_ExportPath) = Empty Then
        Call MkDir(s_ExportPath)
    End If

    Select Case Application.DefaultSaveFormat
        Case xlOpenXMLWorkbook
            s_ExportFile = s_Distance & ".xlsx"
        Case xlOpenXMLWorkbookMacroEnabled
            s_ExportFile = s_Distance & ".xlsm"
        Case xlExcel12
            s_ExportFile = s_Distance & ".xlsb"
        Case xlExcel8
            s_ExportFile = s_Distance & ".xls"
        Case xlCSV
            s_ExportFile = s_Distance & ".csv"
        Case Else
            s_ExportFile = s_Distance
    End Select
    Call wb_Export.SaveAs(Filename:=s_ExportPath & s_ExportFile, FileFormat:=Application.DefaultSaveFormat)

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub


Public Function GetNextSheetname(s_Name As String, Optional wb_Book As Workbook) As String
Dim l_FIndex  As Long
Dim s_Target As String
    If wb_Book Is Nothing Then Set wb_Book = ActiveWorkbook
    s_Name = Left(s_Name, 31)
    If IsValidSheet(wb_Book, s_Name) Then
        l_FIndex = 1
        s_Target = Left(s_Name, 27) & " (" & l_FIndex & ")"

        Do While IsValidSheet(wb_Book, s_Target)
            l_FIndex = l_FIndex + 1
            If l_FIndex < 10 Then
                s_Target = Left(s_Name, 27) & " (" & l_FIndex & ")"
            ElseIf l_FIndex < 100 Then
                s_Target = Left(s_Name, 26) & " (" & l_FIndex & ")"
            ElseIf l_FIndex < 1000 Then
                s_Target = Left(s_Name, 25) & " (" & l_FIndex & ")"
            End If
        Loop
        GetNextSheetname = s_Target
    Else
        GetNextSheetname = s_Name
    End If
End Function


Public Function IsValidSheet(wbSearchBook As Workbook, v_TestIndex As Variant) As Boolean
Dim v_Index As Variant
On Error GoTo ExitLine
    v_Index = wbSearchBook.Worksheets(v_TestIndex).Name
    IsValidSheet = True
    Exit Function

ExitLine:
    IsValidSheet = False
End Function

请您帮助我循环浏览一个值列表，而不是每次都手动运行宏并自己输入值？

Answer 1

下载此example here。

这是一个简单的例子，说明如何遍历一个范围并循环通过另一个范围来查找值。它循环遍历D列然后循环遍历A列，当它找到匹配时它会做某事，所以基本上D列代替了你的输入框。

运行宏

代码

Sub DblLoop()

    Dim aLp As Range    'column A
    Dim dLp As Range, dRw As Long    'column D
    Dim d As Range, a As Range


    Set aLp = Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
    dRw = Cells(Rows.Count, "D").End(xlUp).Row
    Set dLp = Range("D2:D" & dRw)

    'start the loop
    'loops through column D and finds value
    'in column A, and does something with it

    For Each d In dLp.Cells    'loops through column D
        For Each a In aLp.Cells    'loops through column A

            If d = a Then
                'When a match, then do something
                'this is where your actual code would go
                Range("A" & a.Row & ":B" & a.Row).Copy Cells(Rows.Count, "F").End(xlUp).Offset(1)

            End If
        Next a    'keeps going through column A
    Next d    'next item in column D


End Sub

循环以浏览值列表

1 个答案: