kurt0101
06-30-2008, 07:26 PM
Hi. I have a macro that arranges data in a particular way. I always have my data on cell A18-A*** to H18-H*** when I run the macro.
My only problem is that after I run the macro it "picks up" the data and shifts it all the way to cell J18 (9 columns) but I want the output to START at A18-H18, then J18-Q18 etc etc. I do not understand why it is shifting it over. that is the only thing i want to change.
I have pasted it below. thank you very much
Sub DoIt()
Selection.CurrentRegion.Select
On Error GoTo cancelled
Set UserRange = _
Application.InputBox("Confirm or adjust the range to process (include the headers)", _
"Confirm range to process", Selection.Address, , , , , 8)
UserRange.Select
On Error GoTo 0
'Selection.Sort Key1:=Selection.Range("B4"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
'pd changed line below
Selection.Sort Key1:=Range("C15"), Order1:=xlAscending, Key2:=Range("B15"), _
Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
Set myheaders = Selection.Rows(1)
Selection.Rows("2:" & Selection.Rows.Count).Select
SelTopRow = Selection.Row
SelWidth = Selection.Columns.Count
batchno = 1 'pd changed
Rw = 1
startrow = 1
Do Until Rw > Selection.Rows.Count
Do Until Selection.Cells(startrow, 2) <> Selection.Cells(Rw + 1, 2) Or _
Selection.Cells(startrow, 3) <> Selection.Cells(Rw + 1, 3) Or Rw > _
Selection.Rows.Count 'pd changed
Rw = Rw + 1
Loop
If Selection.Rows(startrow).Cells(2) <> "" Then 'batchno > 0 Then 'pd changed
Set mysource = Selection.Rows(startrow & ":" & Rw)
Set mydest = Selection.Cells(1, 1).Offset(, batchno * (SelWidth + _
1)).Resize(Rw - startrow + 1, SelWidth)
mysource.Copy mydest
mysource.Clear
Set mydest = mydest.Rows(1).Offset(-1)
myheaders.Copy mydest
thisDepth = mydest.Cells(1).End(xlDown).Row - mydest.Row
lastDepth = mydest.Cells(1).Offset(, -2).End(xlDown).Row - _
mydest.Row
blackDepth = WorksheetFunction.Max(thisDepth, lastDepth)
mydest.Cells(1).Offset(, -1).Resize(blackDepth + _
1).Interior.ColorIndex = 1
mydest.Cells(1).Offset(, -1).ColumnWidth = 12#
mydest.EntireColumn.AutoFit
End If
Rw = Rw + 1: startrow = Rw: batchno = batchno + 1
Loop
Selection.Offset(-1).Resize(Selection.Rows.Count + 1, _
Selection.Columns.Count + 1).Delete Shift:=xlToLeft 'pd added
cancelled:
End Sub
Reformatted code to stop side scrolling.
~Oorang
My only problem is that after I run the macro it "picks up" the data and shifts it all the way to cell J18 (9 columns) but I want the output to START at A18-H18, then J18-Q18 etc etc. I do not understand why it is shifting it over. that is the only thing i want to change.
I have pasted it below. thank you very much
Sub DoIt()
Selection.CurrentRegion.Select
On Error GoTo cancelled
Set UserRange = _
Application.InputBox("Confirm or adjust the range to process (include the headers)", _
"Confirm range to process", Selection.Address, , , , , 8)
UserRange.Select
On Error GoTo 0
'Selection.Sort Key1:=Selection.Range("B4"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
'pd changed line below
Selection.Sort Key1:=Range("C15"), Order1:=xlAscending, Key2:=Range("B15"), _
Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
Set myheaders = Selection.Rows(1)
Selection.Rows("2:" & Selection.Rows.Count).Select
SelTopRow = Selection.Row
SelWidth = Selection.Columns.Count
batchno = 1 'pd changed
Rw = 1
startrow = 1
Do Until Rw > Selection.Rows.Count
Do Until Selection.Cells(startrow, 2) <> Selection.Cells(Rw + 1, 2) Or _
Selection.Cells(startrow, 3) <> Selection.Cells(Rw + 1, 3) Or Rw > _
Selection.Rows.Count 'pd changed
Rw = Rw + 1
Loop
If Selection.Rows(startrow).Cells(2) <> "" Then 'batchno > 0 Then 'pd changed
Set mysource = Selection.Rows(startrow & ":" & Rw)
Set mydest = Selection.Cells(1, 1).Offset(, batchno * (SelWidth + _
1)).Resize(Rw - startrow + 1, SelWidth)
mysource.Copy mydest
mysource.Clear
Set mydest = mydest.Rows(1).Offset(-1)
myheaders.Copy mydest
thisDepth = mydest.Cells(1).End(xlDown).Row - mydest.Row
lastDepth = mydest.Cells(1).Offset(, -2).End(xlDown).Row - _
mydest.Row
blackDepth = WorksheetFunction.Max(thisDepth, lastDepth)
mydest.Cells(1).Offset(, -1).Resize(blackDepth + _
1).Interior.ColorIndex = 1
mydest.Cells(1).Offset(, -1).ColumnWidth = 12#
mydest.EntireColumn.AutoFit
End If
Rw = Rw + 1: startrow = Rw: batchno = batchno + 1
Loop
Selection.Offset(-1).Resize(Selection.Rows.Count + 1, _
Selection.Columns.Count + 1).Delete Shift:=xlToLeft 'pd added
cancelled:
End Sub
Reformatted code to stop side scrolling.
~Oorang