|
step2大大的有问题。按你思路改编了一下,没用字典,希望能看懂。- Sub step2()
- With Sheets(1)
- arr = .Range("A1").CurrentRegion
- xstr = Join(Application.Transpose(.Range("I2:I" & .[I10000].End(xlUp).Row)), "") 'I列的结果,进字符串,以便比较
- End With
-
- ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
- ReDim drr(1 To UBound(arr), 1 To UBound(arr, 2))
- ReDim err(1 To UBound(arr), 1 To UBound(arr, 2))
- ReDim frr(1 To UBound(arr), 1 To UBound(arr, 2))
-
- Dim Flag As Boolean '判断本行是否已经筛选出
- For i = 2 To UBound(arr)
- Flag = False
- If Len(arr(i, 3) & arr(i, 4)) Then 'code1 code2任一不为空
- Flag = True
- k4 = k4 + 1
- For j = 1 To 6: err(k4, j) = arr(i, j): Next j
- Else
- If InStr(xstr, arr(i, 1)) > 0 Then '在I列所示的Name中
- If arr(i, 5) = "20" Then
- Flag = True
- k3 = k3 + 1
- For j = 1 To 6: drr(k3, j) = arr(i, j): Next j
- ElseIf arr(i, 5) = "10" And arr(i, 6) = "XX" Then
- Flag = True
- k2 = k2 + 1
- For j = 1 To 6: crr(k2, j) = arr(i, j): Next j
- End If
- End If
- End If
- If Flag = False Then
- k5 = k5 + 1
- For j = 1 To 6: frr(k5, j) = arr(i, j): Next j
- End If
- Next
-
- Application.DisplayAlerts = False
- shrr = Array("10", "20", "Code1_Code2", "Other")
- On Error Resume Next
- For i = 0 To UBound(shrr) '生成各工作表,复制表头
- Sheets(shrr(i)).Delete
- Worksheets.Add after:=Sheets(Sheets.Count)
- With ActiveSheet
- .Name = shrr(i)
- .Cells.Clear
- Sheets(1).[a1:f1].Copy .[a1]
- End With
- Next
- Application.DisplayAlerts = True
- Sheets(2).Range("A2").Resize(k2, 6) = crr
- Sheets(3).Range("A2").Resize(k3, 6) = drr
- Sheets(4).Range("A2").Resize(k4, 6) = err
- Sheets(5).Range("A2").Resize(k5, 6) = frr
- End Sub
复制代码 |
|