Петля, чтобы просмотреть список значений

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