ADVERTISEMENT
ADVERTISEMENT
Dim i As integer
Dim rng As Range
Dim partsRng
Dim cell As Object
Dim cellAdd As String
Dim c As String
Dim h As Integer
h = 0
ReDim partsArray(3)
partsArray(0) = "C80001"
partsArray(1) = "C80010"
partsArray(2) = "C80100"
ReDim array1(5)
ReDim array2(5)
ReDim array3(5)
For i = 0 to 2
set partsRng = Range("A1:A100")
For each cell in partsRng
if cell.Value = partsArray(i) then
c = cell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
cellAdd = Mid(c, 1, 1)
Set rng = Range("A" & cellAdd & ":" & "G" & cellAdd)
If i = 0 then
array1(h) = rng
Elseif i = 1 then
array2(h) = rng
Else
array3(h) = rng
End if
h = h + 1
Next
i = i + 1
Next
Sub test()
Dim h As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim rng As Range
Dim partsRng As Range
Dim cell As Range
Dim topmost As Integer
Dim array1()
Dim array2()
Dim array3()
Set partsRng = Range("A1:A100")
topmost = Application.WorksheetFunction.CountIf(partsRng, "=C80001")
If topmost < Application.WorksheetFunction.CountIf(partsRng, "=C80010") Then topmost = Application.WorksheetFunction.CountIf(partsRng, "=C80010")
If topmost < Application.WorksheetFunction.CountIf(partsRng, "=C80100") Then topmost = Application.WorksheetFunction.CountIf(partsRng, "=C80100")
ReDim array1(topmost)
ReDim array2(topmost)
ReDim array3(topmost)
For Each cell In partsRng
If cell.Value = "C80001" Or cell.Value = "C80010" Or cell.Value = "C80100" Then
Set rng = Range("A" & cell.Row & ":" & "G" & cell.Row)
If cell.Value = "C80001" Then
array1(h) = rng
h = h + 1
ElseIf cell.Value = "C80010" Then
array2(i) = rng
i = i + 1
ElseIf cell.Value = "C80100" Then
array3(j) = rng
j = j + 1
End If
End If
Next cell
For k = 0 To topmost
Sheets("Sheet2").Range("A1:G1").Offset(k, 0) = array1(k)
Sheets("Sheet2").Range("H1:N1").Offset(k, 0) = array2(k)
Sheets("Sheet2").Range("O1:U1").Offset(k, 0) = array3(k)
Next