Excel: Move to Tab, replaces information

Microsoft Excel 2003 (full product)
July 26, 2010 at 16:00:07
Specs: Windows XP
I'm trying to create a macro which queries data in a worksheet and, based on a name in column B, creates a new worksheet (titled the same as the name it finds) and copies the data from that row into the worksheet.

The code below almost does what I need

Public Sub MoveToTab()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range

On Error GoTo ErrHnd

With Worksheets("Source")
'set start as B2 i.e., after heading row in column B
Set rngStart = .Range("b2")
'set end - last used row in column Q
Set rngEnd = .Range("b" & CStr(Application.Rows.Count)).End(xlUp)

'loop through cells in column A
For Each rngCell In Range(rngStart, rngEnd)
'test if tab exists
On Error Resume Next
If Not Worksheets(rngCell.Text).Name <> "" Then
On Error GoTo ErrHnd
'No worksheet 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("A2") _
.Offset(Worksheets(rngCell.Text).UsedRange.Rows.Count, 0)
End If
Next rngCell
End With
Exit Sub

'error handler
ErrHnd:
Err.Clear
End Sub

The problem is if I run the report two times in a row, it creates duplicates because it's putting the same information in the next empty cell. What I would like it to do is repaste in A2 and replace the existing data. This will also allow me to update rows, click on the macro and have only the updated line showing.

Any help would be greatly appreciated, thanks


See More: Excel: Move to Tab, replaces information

Report •

#1
July 26, 2010 at 17:39:23
Try changing this section:

'copy row to end of used range
rngCell.EntireRow.Copy 
Destination:=Worksheets(rngCell.Text).Range("A2") _
.Offset(Worksheets(rngCell.Text).UsedRange.Rows.Count, 0)

to just:

'copy row to Row 1
rngCell.EntireRow.Copy 
Destination:=Worksheets(rngCell.Text).Range("A1")

This will continually paste the copied data into Row 1, replacing the data that was put there when the sheet was created.


Report •

#2
July 27, 2010 at 10:42:21
Thanks for the quick response.

That does get rid of the duplicates, however for some reason only 1 row of data is getting copied to each tab. For example: If I have the following info in the Source data tab
# Person Status
12345 AM Pending
54312 KY Pending
43532 KY Pending

When I run the report both AM and KY tabs get created but only the bottom KY # shows up in that tab, # 54312 does not. Any suggestions?


Report •

#3
July 27, 2010 at 11:23:59
re: for some reason only 1 row of data is getting copied to each tab.

Not true. All of the data is being copied, but since I modified the code to fit what you asked for, you are only seeing the last thing that was copied.

In your OP you said:

"What I would like it to do is repaste in A2 and replace the existing data."

That's exactly what my code does.

What you are asking for now is different. You now want the individual sheets to show all of the rows related to each item in Column B, but have them contain the most recent changes. That is a very different request.

This version deletes all of the sheets in the workbook except for the Source sheet. It then recreates the sheets, copying each row of data to the next empty row.

I suggest you try this in a backup copy of your workbook as changes made by a macro can not be undone.

Public Sub MoveToTab()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range

On Error GoTo ErrHnd
 Application.DisplayAlerts = False
  For shtNum = Sheets.Count To 1 Step -1
   If Sheets(shtNum).Name <> "Source" Then Sheets(shtNum).Delete
  Next
 Application.DisplayAlerts = True
  
With Worksheets("Source")
'set start as B2 i.e., after heading row in column B
Set rngStart = .Range("b2")
'set end - last used row in column Q
Set rngEnd = .Range("b" & CStr(Application.Rows.Count)).End(xlUp)

'loop through cells in column A
For Each rngCell In Range(rngStart, rngEnd)
'test if tab exists
On Error Resume Next
If Not Worksheets(rngCell.Text).Name <> "" Then
On Error GoTo ErrHnd
'No worksheet 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
End With
Exit Sub

'error handler
ErrHnd:
Err.Clear
End Sub


Report •

Related Solutions

#4
July 27, 2010 at 12:16:15
Hi,

I modified the code to work as follows:

Test each name in column B
If a worksheet of the same name does not exist - create it
If a worksheet of the same name does exist - clear all existing data from it
Then copy the data row by row as a separate 'loop'
As the worksheet names have been tested and created already, this loop just copies the data
Also as some worksheets will have had data cleared, the UsedRange function may not be reliable, so I replaced it with a search for the last used row, (using column B - as this will always have data in it).

As before, please test this on backup copies - my testing has been on very limited data.

Public Sub MoveToTab()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range

On Error GoTo ErrHnd

With Worksheets("Source")
    'set start as B2 i.e., after heading row in column B
    Set rngStart = .Range("B2")
    'set end - last used row in column B
    Set rngEnd = .Range("B" & CStr(Application.Rows.Count)).End(xlUp)
    
    'setup destination worksheets
    'either create new if they don't exist,
    'or clear existing data if they do
    'loop through cells in column B
    For Each rngCell In Range(rngStart, rngEnd)
        'test if tab exists
        On Error Resume Next
        If Not Worksheets(rngCell.Text).Name <> "" Then
            On Error GoTo ErrHnd
            'No worksheet of this name - so create one
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = rngCell.Text
            Else
            On Error GoTo ErrHnd
            'clear data
            Worksheets(rngCell.Text).Cells.Clear
        End If
    Next rngCell
    
    'loop through cells in column B
    For Each rngCell In Range(rngStart, rngEnd)
        'worksheets will all exist
        'copy row to end of used range
        rngCell.EntireRow.Copy _
            Destination:=Worksheets(rngCell.Text) _
            .Range("B" & CStr(Application.Rows.Count)).End(xlUp) _
            .Offset(1, -1)
    Next rngCell
End With
Exit Sub

'error handler
ErrHnd:
Err.Clear
End Sub

Regards


Report •

#5
July 27, 2010 at 14:03:11
Sweet, it's working now. Thanks a lot for your help!

Report •

Ask Question