Alter macro to include all rows

Microsoft Windows xp professional w/serv...
June 1, 2010 at 13:10:48
Specs: Windows XP
I have a macro which sorts data and copies to new worksheets. The mactro currently skips the first row. Can someone help alter this macro to include the first row? I will attach the macro below. Thank you!!

Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("B:B").Select
Selection.Copy
Columns("C:C").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(5, 9)), TrailingMinusNumbers:=True
Range("D4").Select
Dim rngRow As Range
Dim rngCell As Range

On Error GoTo ErrHnd

'use All used rows except first, in 'GL Detail by Month' Worksheet
With Worksheets("GL Detail by Month").UsedRange.Offset(1, 0) _
.Resize(Worksheets("GL Detail by Month").UsedRange.Rows.Count - 1, _
Worksheets("GL Detail by Month").UsedRange.Columns.Count)
'loop through all rows
For Each rngRow In .Rows
'test if tab exists
On Error Resume Next
If Not Worksheets(rngRow.Range("C1").Text).Name <> "" Then
On Error GoTo ErrHnd
'No Tab of this name - so create one and copy row
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = rngRow.Range("C1").Text
rngRow.Copy Destination:=Worksheets(rngRow.Range("C1").Text).Range("A1")
Else
On Error GoTo ErrHnd
'worksheet exists
'copy row to end of used range
rngRow.Copy Destination:=Worksheets(rngRow.Range("C1").Text).Range("A1") _
.Offset(Worksheets(rngRow.Range("C1").Text).UsedRange.Rows.Count, 0)
End If
Next rngRow
End With


'error handler
ErrHnd:
Err.Clear


See More: Alter macro to include all rows

Report •


#1
June 8, 2010 at 06:32:21
Hi,

The first part of your macro can be simplified, as in VBA it is rarely necessary to 'Select' a range before carrying out an action.

This should do the same:
Columns("C:C").Insert Shift:=xlToRight
Columns("B:B").Copy Destination:=ActiveSheet.Range("C1")
Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(5, 9)), TrailingMinusNumbers:=True

I don't know what data you have, so I can't test the TextToColumns function.

The following line identifies the range of cells that will be acted on.
With Worksheets("GL Detail by Month").UsedRange.Offset(1, 0) _
.Resize(Worksheets("GL Detail by Month").UsedRange.Rows.Count - 1, _
Worksheets("GL Detail by Month").UsedRange.Columns.Count)
It starts by taking the 'Used range' on the worksheet "GL Detail by Month"
It then moves the start of the selected range down one row by using Offset(1, 0)
This explains why the first row is excluded.
It then resizes the selected range to one less row than the original used range, with UsedRange.Rows.Count - 1, and it keeps the same number of columns as the original range with UsedRange.Columns.Count

To just use the 'UsedRange' including the first row, the line can just be:
With Worksheets("GL Detail by Month").UsedRange

The rest of the code should work as before, although there is a Exit Sub missing before the error handler. This means that the error handler code runs every time - not a big problem, but not necessary.
It should be:

End With
Exit Sub

'error handler

If you get a lot of screen flicker and/or the code runs slowly, turning off screen updating may help.
Add this line at the start of the code:
Application.ScreenUpdating = False
and before Exit Sub
Application.ScreenUpdating = True
and before End Sub
Application.ScreenUpdating = True

Used Range can be unpredictable if data has been entered into cells and later deleted. If you find that you are not getting the expected data copied you can try finding the used cells by testing column C (I used column C as this appears to be the column with the worksheet names).
The following uses the .End(xlUp) method to find the end of the data in column C.
The code is a little simpler as it loops through just the cells in column C and then selects the whole row to copy using 'EntireRow', rather than looping through entire rows and having to select the cell in column C each time - it does the same thing - but with a bit less code.

Option Explicit

Private Sub CommandButton1_Click()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range

On Error GoTo ErrHnd

Application.ScreenUpdating = False

Columns("C:C").Insert Shift:=xlToRight
Columns("B:B").Copy Destination:=ActiveSheet.Range("C1")
Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(5, 9)), TrailingMinusNumbers:=True

'set start of range in column C
Set rngStart = Worksheets("GL Detail by Month").Range("C1")
'set end of range in column C in 'GL Detail by Month' Worksheet
Set rngEnd = Worksheets("GL Detail by Month"). _
             Range("C" & CStr(Application.Rows.Count)).End(xlUp)

'loop through all used cells in Column C
For Each rngCell In Range(rngStart, rngEnd)
    'test if tab exists using text in cells in column C
    On Error Resume Next
    If Not Worksheets(rngCell.Text).Name <> "" Then
        On Error GoTo ErrHnd
        'No Tab of this name - so create one and copy row
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        Worksheets(Worksheets.Count).Name = rngCell.Text
        rngCell.EntireRow.Copy Destination:=Worksheets(rngCell.Text).Range("A1")
        Else
        On Error GoTo ErrHnd
        'worksheet exists
        'copy row to end of used range
        rngCell.EntireRow.Copy Destination:=Worksheets(rngCell.Text).Range("A1") _
        .Offset(Worksheets(rngCell.Text).UsedRange.Rows.Count, 0)
    End If
Next rngCell
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
Application.ScreenUpdating = True
End Sub

As changes made by macros cannot be undone with the Undo button, please test any changes on a backup copy of your workbook. Always make a backup before running a macro. I have not tested these changes on your data, or in your environment, so please test it on backups, to ensure it works 'as expected'.

Hope this solves your problem.

Regards


Report •
Related Solutions


Ask Question