要使用循环而不是单独的代码，直到最后一行

我试图find列A到列H中的唯一名称，并根据H列中的值和我能够获得的列A中的值筛选数​​据，但是我无法使其工作，直到最后一行数据列于H.

请帮我修改代码，使其可以运行，直到列H中的最后一行build议适当的修改来定义标准范围，而我已经在下面分别针对每个单元完成了。 我用循环不好，但试图解决它，但仍然无法纠正，使其工作。 我无法正确定义范围并使其工作。 如果任何专家能够抽出时间，研究这个问题，纠正和改进我的代码，那将是非常有帮助的。

Sub Test() Dim ws2 As Worksheet, sheetxxx As Worksheet Dim cnt As Long Dim rCrit1 As Range, rCrit2 As Range, rCrit3 As Range, rCrit4 As Range, rRng1 As Range, rRng2 As Range Dim i As Long, LastRow As Long LastRow = Cells(Rows.Count, "A").End(xlUp).Row With Application .EnableEvents = False .ScreenUpdating = False End With 'Instead of defining this range separately, is there a way to run from H2 To Last Row of data in H column Set rCrit1 = Range("H2") Set rCrit2 = Range("H3") Set rCrit3 = Range("H4") Set rCrit4 = Range("H5") Set rRng1 = Range("A1:C60000") With rRng1 .AutoFilter field:=1, Criteria1:=rCrit1.Value cnt = WorksheetFunction.Subtotal(3, .Range("A:A")) If cnt >= 2 Then Worksheets.Add After:=Worksheets(Worksheets.Count) Set sheetxxx = ActiveWorkbook.ActiveSheet sheetxxx.Name = Worksheets("Sheet3").Range("H2").Value 'instead use i for range to check for 2 to lastrow .Range(.Range("A1"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 5).Copy sheetxxx.Range("A1").PasteSpecial Paste:=xlPasteAll With sheetxxx .Range(.Range("A1"), .Cells(cnt, 5)).Borders.LineStyle = xlContinuous .Range("a1:z1").Font.FontStyle = "Bold Italic" .Columns("a:z").AutoFit .Range("a1").Select End With End If End With Sheets("Sheet3").Activate With Sheets("sheet3") .AutoFilterMode = False End With With rRng1 .AutoFilter field:=1, Criteria1:=rCrit2.Value cnt = WorksheetFunction.Subtotal(3, .Range("A:A")) If cnt >= 2 Then Worksheets.Add After:=Worksheets(Worksheets.Count) Set sheetxxx = ActiveWorkbook.ActiveSheet sheetxxx.Name = Worksheets("Sheet3").Range("H3").Value .Range(.Range("A1"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 5).Copy sheetxxx.Range("A1").PasteSpecial Paste:=xlPasteAll With sheetxxx .Range(.Range("A1"), .Cells(cnt, 5)).Borders.LineStyle = xlContinuous .Range("a1:z1").Font.FontStyle = "Bold Italic" .Columns("a:z").AutoFit .Range("a1").Select End With End If End With Sheets("Sheet3").Activate With Sheets("sheet3") .AutoFilterMode = False End With With rRng1 .AutoFilter field:=1, Criteria1:=rCrit3.Value cnt = WorksheetFunction.Subtotal(3, .Range("A:A")) If cnt >= 2 Then Worksheets.Add After:=Worksheets(Worksheets.Count) Set sheetxxx = ActiveWorkbook.ActiveSheet sheetxxx.Name = Worksheets("Sheet3").Range("H4").Value .Range(.Range("A1"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 5).Copy sheetxxx.Range("A1").PasteSpecial Paste:=xlPasteAll With sheetxxx .Range(.Range("A1"), .Cells(cnt, 5)).Borders.LineStyle = xlContinuous .Range("a1:z1").Font.FontStyle = "Bold Italic" .Columns("a:z").AutoFit .Range("a1").Select End With End If End With Sheets("Sheet3").Activate With Sheets("sheet3") .AutoFilterMode = False End With With rRng1 .AutoFilter field:=1, Criteria1:=rCrit4.Value cnt = WorksheetFunction.Subtotal(3, .Range("A:A")) If cnt >= 2 Then Worksheets.Add After:=Worksheets(Worksheets.Count) Set sheetxxx = ActiveWorkbook.ActiveSheet sheetxxx.Name = Worksheets("Sheet3").Range("H5").Value .Range(.Range("A1"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 5).Copy sheetxxx.Range("A1").PasteSpecial Paste:=xlPasteAll With sheetxxx .Range(.Range("A1"), .Cells(cnt, 5)).Borders.LineStyle = xlContinuous .Range("a1:z1").Font.FontStyle = "Bold Italic" .Columns("a:z").AutoFit .Range("a1").Select End With End If End With Sheets("Sheet3").Activate With Sheets("sheet3") .AutoFilterMode = False End With With Application .EnableEvents = True .ScreenUpdating = True End With End Sub 

Answer 1

没有真实的数据，不可能完全testing，但是这应该做你想要的：

 Sub Test() Dim sheetxxx As Worksheet, rCrit As Range, runner As Variant Application.EnableEvents = False Application.ScreenUpdating = False With Sheets("Sheet3") Set rCrit = .Range("H2", .Cells(.Rows.Count, "H").End(xlUp)) For Each runner In rCrit.Cells If Application.CountIf(.Columns(1), runner) Then .Range("A:C").AutoFilter 1, runner Set sheetxxx = Worksheets.Add(, Sheets(Sheets.Count)) sheetxxx.Name = runner.Value .Range(.Range("A1"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 5).Copy sheetxxx.Range("A1") With sheetxxx .Range(.Range("A1"), .Cells(Application.Subtotal(3, .Columns(1)), 5)).Borders.LineStyle = xlContinuous .Range("A1:Z1").Font.FontStyle = "Bold Italic" .Range("A:Z").AutoFit End With .Activate .AutoFilterMode = False End If Next End With Application.EnableEvents = True Application.ScreenUpdating = True End Sub 

编辑

runner ：它只是在For Each ... In ... 。 在我的代码中， For Each runner In rCrit.Cells的For Each runner In rCrit.Cells只需要运行rCrit -range中每个单元的整个循环。 所以而不是一个For i = ... To ... i是一个数字，我的runner将是单元格。 所以在第一轮runner将和Range("H2") 。 在第二个Range("H4")等等直到rCrit的最后一个单元格。

作为一个节省时间，我使用Application.CountIf(.Columns(1), runner)检查结果没有sorting。 如果是肯定的，还是需要sorting。

除此之外，大部分应该像以前一样。
如果还有其他问题，请问一下）