如果某个条件满足,我创建了一个VBA应用程序将结果提取到另一个工作表,并插入一个空行,然后下一个提取下一个结果。我的VBA只提取第一个结果而不是继续,任何人都可以帮忙吗?
Option Explicit
Sub ClearCustomer()
Dim i As Variant, j As Variant, k As Variant
Dim LastRow As Long
Dim LastRow2 As Long
Dim LastRow3 As Long
Dim aFile As String
Dim wb As Workbook
Dim wshell
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim diff As Double
Const tolerance As Long = 100
Application.DisplayAlerts = False
Application.ScreenUpdating = False
aFile = ThisWorkbook.Path & "\FBL5N.XLSX"
If Len(Dir$(aFile)) > 0 Then
Kill aFile
End If
Set wshell = CreateObject("WScript.Shell")
wshell.Run Chr(34) & "C:\Users\nxkan\Desktop\AUTO\FBL5N.vbs" & Chr(34), 1, 1
On Error Resume Next
Workbooks.Open Filename:=ThisWorkbook.Path & "\FBL5N.XLSX"
Set wb = Workbooks("FBL5N.XLSX")
Set ws = wb.Sheets("Sheet1")
ws.Range("A:C,E:F,I:I,L:L").EntireColumn.Delete
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "FBL5N"
Set ws1 = wb.Sheets("FBL5N")
LastRow = ws.Range("F" & Rows.Count).End(xlUp).Row
LastRow2 = ws.Range("G" & Rows.Count).End(xlUp).Row
LastRow3 = ws1.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
For j = 2 To LastRow2
For k = 1 To LastRow3
If ws.Cells(i, 6).Value = ws.Cells(j, 7).Value Then
diff = Application.WorksheetFunction.SumIf(ws.Range(ws.Cells(2, 6), ws.Cells(i, 6)), ws.Cells(i, 6), ws.Range(ws.Cells(2, 4), ws.Cells(i, 4))) + Application.WorksheetFunction.SumIf(ws.Range(ws.Cells(2, 7), ws.Cells(j, 7)), ws.Cells(j, 7), ws.Range(ws.Cells(2, 4), ws.Cells(j, 4)))
If diff <= tolerance And diff >= -tolerance Then
ws1.Cells(k, 1).Value = ws.Cells(i, 1).Value
ws1.Cells(k, 2).Value = ws.Cells(i, 2).Value
ws1.Cells(k, 3).Value = ws.Cells(i, 3).Value
ws1.Cells(k, 4).Value = ws.Cells(i, 4).Value
ws1.Cells(k, 5).Value = ws.Cells(i, 5).Value
ws1.Cells(k, 6).Value = ws.Cells(i, 6).Value
ws1.Cells(k, 7).Value = ws.Cells(i, 7).Value
ws1.Cells(k + 1, 1).Value = ws.Cells(j, 1).Value
ws1.Cells(k + 1, 2).Value = ws.Cells(j, 2).Value
ws1.Cells(k + 1, 3).Value = ws.Cells(j, 3).Value
ws1.Cells(k + 1, 4).Value = ws.Cells(j, 4).Value
ws1.Cells(k + 1, 5).Value = ws.Cells(j, 5).Value
ws1.Cells(k + 1, 6).Value = ws.Cells(j, 6).Value
ws1.Cells(k + 1, 7).Value = ws.Cells(j, 7).Value
Exit For
End If
End If
k = k + 3
Next k
Next j
Next i
'With ActiveSheet
'.AutoFilterMode = False
'.Range("A1:K1").AutoFilter Field:=7, Criteria1:="<>"
'End With
MsgBox "Finished"
End Sub