macro to conditionally cut rows to new sheet

Microsoft Office 2000 standard
June 4, 2010 at 07:35:40
Specs: Windows XP
Hi!

I am trying to conditionally cut rows from sheet2 to new sheets based on the values in row A. The values in row are are numbers (1,2,3, etc) and are there will be a different amount of rows for each time the report is run (but we can say no more than 5000) but probably only about 80 values in row A (as many rows will have the same number).

I would like to get all of the rows with value 1 to a new tab labeled 1, all rows with value 2 to a new tab labeled 2, and so on. These rows can be either copied or cut from sheet2.

Any help would be much appreciated!


See More: macro to conditionally cut rows to new sheet

Report •


#1
June 4, 2010 at 07:38:14
Oh and there are five columns with data that need to be copied to the new tabs (Column A-E)

Report •

#2
June 5, 2010 at 11:11:36
Hi,

On Worksheet 'Sheet2', create a command button from the Control Toolbox toolbar.
(If this isn't visible, right click on an existing toolbar and check the Control Toolbox).
Select the button Icon and draw a button
Right-click the button and select Command Button - Edit and change the name to 'Transfer' or something suitable.
Right-click the button again and select View Code
In the code window that opens enter this:

Option Explicit

Private Sub CommandButton1_Click()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestEnd As Range
Dim strWsName As String

On Error GoTo ErrHnd

'turn off screen updating to stop flicker
Application.ScreenUpdating = False

'set start of data (range containing names/numbers for worksheets)
Set rngStart = Worksheets("Sheet2").Range("A2")

'set end of range
Set rngEnd = Worksheets("Sheet2"). _
        Range("A" & CStr(Application.Rows.Count)).End(xlUp)

'Loop through all cells with sheet names/numbers
For Each rngCell In Range(rngStart, rngEnd)
    'get name/number
    strWsName = rngCell.Text
    On Error Resume Next
    If Worksheets(strWsName) Is Nothing Then
        'worksheet does not exist, so create & name it
        On Error GoTo ErrHnd
        'create new sheet
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        'name new sheet
        Worksheets(Worksheets.Count).Name = strWsName
    End If
    'if name was valid for a worksheet, copy 5 cells to that named sheet
    'find empty row after end of destination data
    Set rngDestEnd = Worksheets(strWsName). _
            Range("A" & CStr(Application.Rows.Count)). _
            End(xlUp).Offset(1, 0)
    rngCell.Resize(1, 5).Copy
    rngDestEnd.PasteSpecial (xlPasteValuesAndNumberFormats)
Next rngCell
'restore screen updating
Application.ScreenUpdating = True
Exit Sub

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

Note that Private Sub CommandButton1_Click() and End sub will already be present, so don't duplicate them. Option Explicit goes before Private Sub CommandButton1_Click().
Some lines of code have been split onto two lines for ease of viewing, using the line continuation character "_". This should work 'as is' just copy and paste, or you could remove the "_" and bring the code back to one line.

Click Save from the Visual Basic Menu.

Alt+f11 takes you back to the main Excel window.
Exit design mode (first icon on the Controls Toolbox toolbar).

As changes made by Macros cannot be undone with the Undo button, test this macro on a copy of your data. Always make a backup of your Workbook before running this macro. This code has only been tested on sample data, and it has not been tested in your environment, so test it on copies of your data to ensure that it works 'as expected'

Click the 'Transfer' button to run the macro.

Hope this was what you were looking for.

Regards


Report •

#3
June 7, 2010 at 07:28:05
Thank you so much for your help!

When I run this macro it comes up with the error: Compile Error: Variable not defined and highlights
rngDestEnd.PasteSpecial (xlPasteValuesAndNumberFormats)

Can you think of a way to fix this? Also, for my data, it won't always be a specific number of rows that will need to be transfered to the other tab (I think you had set it to copy 5 cells)...is there a way to do that conditionally? For example, in one set of the data, there are 26 rows with the number "1" associated with it and 12 rows with the number "2" associated with it. Is there a way to separate these into separate tabs based solely on which number is tied to it (from Column A)?

Or is that part of the code related to the 5 columns that would be copied and I am just reading this wrong? (Sorry I'm very new with macros so not too familiar with the code language!)


Report •

Related Solutions

#4
June 7, 2010 at 10:01:11
I have been playing around with this macro and have the following code:

Private Sub CommandButton1_Click()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestEnd As Range
Dim strWsName As String


'turn off screen updating to stop flicker
Application.ScreenUpdating = False

'set start of data (range containing names/numbers for worksheets)
Set rngStart = Worksheets("Sheet2").Range("A2")

'set end of range
Set rngEnd = Worksheets("Sheet2"). _
Range("A" & CStr(Application.Rows.Count)).End(xlUp)

'Loop through all cells with sheet names/numbers
For Each rngCell In Range(rngStart, rngEnd)
'get name/number
strWsName = rngCell.Text
On Error Resume Next
If Worksheets(strWsName) Is Nothing Then
'worksheet does not exist, so create & name it

'create new sheet
Worksheets.Add after:=Worksheets(Worksheets.Count)
'name new sheet
Worksheets(Worksheets.Count).Name = strWsName
End If
'if name was valid for a worksheet, copy 5 cells to that named sheet
'find empty row after end of destination data
Set rngDestEnd = Worksheets(strWsName). _
Range("A" & CStr(Application.Rows.Count)). _
End(xlUp).Offset(1, 0)
rngCell.Resize(1, 5).Copy
rngDestEnd.PasteSpecial (xlPasteValuesAndNumberFormats)
Next rngCell
'restore screen updating
Application.ScreenUpdating = True

End Sub


I took out the error and the option explicit because it was causing an error. Now the macro will work but it isn't copying any of the data into the newly formed tabs. Any suggestions?

Thanks so much again for the help!


Report •

#5
June 7, 2010 at 14:18:25
Hi,

I have a feeling that the error is due to the version of Excel you are using.

The reason for using Option Explicit is to give a warning when some part of the code has not been pre-defined. Most words in the code are either key words such as Range or Set, or they are variables that you have defined such as strWsName which was defined in a Dim statement. There are also constants, in this case xlPasteValuesAndNumberFormats. xlPasteValuesAndNumberFormats is just a name 'standing in' for a value.

Removing Option Explicit removes the warning, but does not remove the error - the error is still there, you just don't get an early warning about it and of course the program fails.

I think that the xlPasteValuesAndNumberFormats has to be replaced by a number as Excel 2000 doesn't recognize the constant name. Try replacing it with 12:
rngDestEnd.PasteSpecial (12)

If that doesn't work try:
rngDestEnd.Paste

rngCell.Resize(1, 5).Copy is about copying the five columns
there are five columns with data that need to be copied to the new tabs (Column A-E)
rngCell is a single cell in column A, and Resize takes two arguments, Rows and Columns - so we want to resize to one row and 5 columns and copy those five cells, which are then pasted (we hope!)

Regards


Report •

#6
June 8, 2010 at 08:03:23
Thanks for your tips - I am using Excel 2000 at work which probably is why there are differences. I put in the following code and now all that happens is one blank sheet is created - any ideas?


Option Explicit

Private Sub CommandButton1_Click()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestEnd As Range
Dim strWsName As String

On Error GoTo ErrHnd

'turn off screen updating to stop flicker
Application.ScreenUpdating = False

'set start of data (range containing names/numbers for worksheets)
Set rngStart = Worksheets("Sheet2").Range("A2")

'set end of range
Set rngEnd = Worksheets("Sheet2"). _
Range("A" & CStr(Application.Rows.Count)).End(xlUp)

'Loop through all cells with sheet names/numbers
For Each rngCell In Range(rngStart, rngEnd)
'get name/number
strWsName = rngCell.Text
On Error Resume Next
If Worksheets(strWsName) Is Nothing Then
'worksheet does not exist, so create & name it
On Error GoTo ErrHnd
'create new sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
'name new sheet
Worksheets(Worksheets.Count).Name = strWsName
End If
'if name was valid for a worksheet, copy 5 cells to that named sheet
'find empty row after end of destination data
Set rngDestEnd = Worksheets(strWsName). _
Range("A" & CStr(Application.Rows.Count)). _
End(xlUp).Offset(1, 0)
rngCell.Resize(1, 5).Copy
rngDestEnd.PasteSpecial (rngDestEnd.paste)
Next rngCell
'restore screen updating
Application.ScreenUpdating = True
Exit Sub

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


Report •

#7
June 8, 2010 at 11:51:34
Hi,
You posted this:
rngCell.Resize(1, 5).Copy
rngDestEnd.PasteSpecial (rngDestEnd.paste)
Next rngCell

Did you try:

rngCell.Resize(1, 5).Copy
rngDestEnd.PasteSpecial (12)
Next rngCell

or

rngCell.Resize(1, 5).Copy
rngDestEnd.Paste
Next rngCell

This line isn't right:
rngDestEnd.PasteSpecial (rngDestEnd.paste)

Regards


Report •

#8
June 9, 2010 at 12:54:13
Yes I have tried both of those options and it's still only creating one new blank sheet... :(

Option Explicit

Private Sub CommandButton1_Click()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestEnd As Range
Dim strWsName As String

On Error GoTo ErrHnd

'turn off screen updating to stop flicker
Application.ScreenUpdating = False

'set start of data (range containing names/numbers for worksheets)
Set rngStart = Worksheets("Sheet2").Range("A2")

'set end of range
Set rngEnd = Worksheets("Sheet2"). _
Range("A" & CStr(Application.Rows.Count)).End(xlUp)

'Loop through all cells with sheet names/numbers
For Each rngCell In Range(rngStart, rngEnd)
'get name/number
strWsName = rngCell.Text
On Error Resume Next
If Worksheets(strWsName) Is Nothing Then
'worksheet does not exist, so create & name it
On Error GoTo ErrHnd
'create new sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
'name new sheet
Worksheets(Worksheets.Count).Name = strWsName
End If
'if name was valid for a worksheet, copy 5 cells to that named sheet
'find empty row after end of destination data
Set rngDestEnd = Worksheets(strWsName). _
Range("A" & CStr(Application.Rows.Count)). _
End(xlUp).Offset(1, 0)
rngCell.Resize(1, 5).Copy
rngDestEnd.paste
Next rngCell
'restore screen updating
Application.ScreenUpdating = True
Exit Sub

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

Thanks!


Report •

#9
June 10, 2010 at 06:00:42
Hi,

I tried this again with:
rngCell.Resize(1, 5).Copy
rngDestEnd.PasteSpecial (xlPasteAll)

If that does not work, put a break in the code at the following line:
For Each rngCell In Range(rngStart, rngEnd)
Do this by clicking in the margin immediately to the left of the word 'For'
A brown dot will appear and the line is highlighted.

Then run the code from the button.
The macro will stop at the break point.
Use the f8 function key to single step.

Let me know if the code jumps to the error handler, and note which line it was on before it jumped.

Regards


Report •

#10
June 10, 2010 at 11:43:01
It works! This is great thank you so much!!! I really appreciate it!

Report •

#11
June 10, 2010 at 16:02:28
You're welcome.

Regards

Humar


Report •

Ask Question