Do you mean name the carriers?
Sub test()
Dim rng As Range, x(), y()
Dim j As Integer, k As Integer, cfind As Range
Dim m As Integer, n As Integer
'j = 0
'k = 0
With Worksheets("sheet1")
m = .Range("a1").End(xlDown).Row
n = .Range("a2").End(xlToRight).Column
'MsgBox "m-1= " & m - 2 & " n-2=" & " " & n - 2
ReDim x(1 To m - 1, 1 To n - 1)
ReDim y(1 To m - 1, 1 To n - 1)
For j = 0 To 3
Set rng = Range(.Range("B2").Offset(j, k), .Range("B2").Offset(j, k).End(xlToRight))
'MsgBox rng.Address
For k = 0 To 4
x(j + 1, k + 1) = WorksheetFunction.Small(rng, k + 1)
Set cfind = rng.Cells.Find(what:=x(j + 1, k + 1), lookat:=xlWhole)
'MsgBox cfind.Address
y(j + 1, k + 1) = .Cells(1, cfind.Column)
'MsgBox x(j + 1, k + 1)
'MsgBox y(j + 1, k + 1)
Next
k = 0
Next
End With
With Worksheets("sheet2")
For j = 0 To 3
If j >= 4 Then GoTo line1
.Range("A2").Offset(j, 0) = Worksheets("sheet1").Range("a2").Offset(j, 0)
For k = 0 To 4
'MsgBox x(j + 1, k + 1)
'MsgBox .Range("B2").Offset(j, k * 2).Address
.Range("B2").Offset(j, k * 2) = x(j + 1, k + 1)
'MsgBox y(j + 1, k + 1)
'MsgBox .Range("B2").Offset(j, k * 2).Offset(0, 1).Address
.Range("B2").Offset(j, k * 2).Offset(0, 1) = y(j + 1, k + 1)
Next
Next
End With
line1:
End Sub| Baseball Guy 2.xls | ||||||||
|---|---|---|---|---|---|---|---|---|
| A | B | C | D | E | F | |||
| 1 | carrierstruckinglane | q | w | e | r | t | ||
| 2 | a | 68 | 3 | 80 | 75 | 76 | ||
| 3 | s | 48 | 57 | 22 | 42 | 43 | ||
| 4 | d | 82 | 27 | 17 | 34 | 63 | ||
| 5 | f | 74 | 57 | 7 | 15 | 88 | ||
Sheet1 | ||||||||
| Baseball Guy 2.xls | |||||||||||||
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| A | B | C | D | E | F | G | H | I | J | K | |||
| 1 | |||||||||||||
| 2 | a | 3 | w | 68 | q | 75 | r | 76 | t | 80 | e | ||
| 3 | s | 22 | e | 42 | r | 43 | t | 48 | q | 57 | w | ||
| 4 | d | 17 | e | 27 | w | 34 | r | 63 | t | 82 | q | ||
| 5 | f | 7 | e | 15 | r | 57 | w | 74 | q | 88 | t | ||
Sheet2 | |||||||||||||
Sub test()
Dim rng As Range, x(), y()
Dim j As Integer, k As Integer, cfind As Range
Dim m As Integer, n As Integer
'j = 0
'k = 0
With Worksheets("sheet1")
m = .Range("a1").End(xlDown).Row
n = .Range("a2").End(xlToRight).Column
'msgbox "m-1= " & m - 1 & " n-2=" & " " & n - 1
ReDim x(1 To m - 1, 1 To 5)
ReDim y(1 To m - 1, 1 To 5)
For j = 0 To m
Set rng = Range(.Range("B2").Offset(j, k), .Range("B2").Offset(j, k).End(xlToRight))
'msgbox rng.Address
For k = 0 To 4
If j = m - 1 Then GoTo line2
x(j + 1, k + 1) = WorksheetFunction.Small(rng, k + 1)
Set cfind = rng.Cells.Find(what:=x(j + 1, k + 1), lookat:=xlWhole)
'msgbox cfind.Address
y(j + 1, k + 1) = .Cells(1, cfind.Column)
'msgbox x(j + 1, k + 1)
'msgbox y(j + 1, k + 1)
Next
k = 0
Next
End With
line2:
With Worksheets("sheet2")
For j = 0 To m - 1
If j >= m - 1 Then GoTo line1
.Range("A2").Offset(j, 0) = Worksheets("sheet1").Range("a2").Offset(j, 0)
For k = 0 To 4
'msgbox x(j + 1, k + 1)
'msgbox .Range("B2").Offset(j, k * 2).Address
.Range("B2").Offset(j, k * 2) = x(j + 1, k + 1)
'msgbox y(j + 1, k + 1)
'msgbox .Range("B2").Offset(j, k * 2).Offset(0, 1).Address
.Range("B2").Offset(j, k * 2).Offset(0, 1) = y(j + 1, k + 1)
Next
Next
End With
line1:
End SubSub test()
Dim rng As Range, x(), y()
Dim j As Integer, k As Integer, cfind As Range
Dim m As Integer, n As Integer
'j = 0
'k = 0
Application.ScreenUpdating = False
With Worksheets("sheet1")
m = .Range("a1").End(xlDown).Row
n = .Range("a2").End(xlToRight).Column
'msgbox "m-1= " & m - 1 & " n-2=" & " " & n - 1
ReDim x(1 To m - 1, 1 To 5)
ReDim y(1 To m - 1, 1 To 5)
'For j = 0 To m
For j = 1 To m - 2
Set rng = Range(.Range("B2").Offset(j, k), .Range("B2").Offset(j, k).End(xlToRight))
'msgbox rng.Address
For k = 0 To 4
'If j = m - 1 Then GoTo line2
x(j + 1, k + 1) = WorksheetFunction.Small(rng, k + 1)
Set cfind = rng.Cells.Find(what:=x(j + 1, k + 1), lookat:=xlWhole)
'msgbox cfind.Address
y(j + 1, k + 1) = .Cells(1, cfind.Column)
'msgbox x(j + 1, k + 1)
'msgbox y(j + 1, k + 1)
Next
k = 0
Next
End With
'line2:
With Worksheets("sheet2")
For j = 0 To m - 2
'If j >= m - 1 Then GoTo line1
.Range("A2").Offset(j, 0) = Worksheets("sheet1").Range("a2").Offset(j, 0)
For k = 0 To 4
'msgbox x(j + 1, k + 1)
'msgbox .Range("B2").Offset(j, k * 2).Address
.Range("B2").Offset(j, k * 2) = x(j + 1, k + 1)
'msgbox y(j + 1, k + 1)
'msgbox .Range("B2").Offset(j, k * 2).Offset(0, 1).Address
.Range("B2").Offset(j, k * 2).Offset(0, 1) = y(j + 1, k + 1)
Next
Next
End With
'line1:
Application.ScreenUpdating = True
End Sub
