Excel VBA code to move data

Dell / Precision t3400
July 8, 2010 at 01:55:59
Specs: Windows XP, 4gb
I have some code (courtesy of Humar on computing.net) 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 does this for each unique name it finds in column B. If it finds a name for which a worksheet already exists, it simply appends that line of data to the relevant worksheet.

The code works perfectly except for the fact that when it pastes the data into the relevant worksheet, I need it to start pasting the data into column B not column A.

Below is the code I am using, with the portion I believe needs to be edited highlighted in bold. It would seem that the obvious thing to do would be to change this line of code:

rngCell.EntireRow.Copy Destination:=Worksheets(rngCell.Text).Range("A1")

to this:

rngCell.EntireRow.Copy Destination:=Worksheets(rngCell.Text).Range("B1")

The result if I do this though is that the code creates only one new worksheet, which is titled after the first name it finds in column B. It doesn't copy over any data and doesn't create any further worksheets.

I'm really not that hot on Excel VBA code and would really appreciate it if anyone could point me in the right direction on this one.

Option Explicit

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

On Error GoTo ErrHnd

With Worksheets("DC")
'sets start as B1
Set rngStart = .Range("B1")
'sets end
Set rngEnd = .Range("B" & CStr(Application.Rows.Count)).End(xlUp)

'loop through cells in column B
For Each rngCell In Range(rngStart, rngEnd)
'tests if tab exists
On Error Resume Next
If Not Worksheets(rngCell.Text).Name <> "" Then
On Error GoTo ErrHnd
'No worksheet of this name - so creates one and copies 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


See More: Excel VBA code to move data

Report •


#1
July 8, 2010 at 04:53:43
Without actually setting up a workbook and testing the code, I'm going to hazard a guess:

The issue is that the code is copying the EntireRow and trying to Paste it into a Range that is smaller than an EntireRow.

If you start the Paste in A1, the EntireRow will fit. If you start the Paste in B1, you'll be 1 cell short of an EntireRow and the code will throw up an error. Once the error is thrown, the "error handler" takes over and the code stops running.

If you want to Paste data starting in B1, then you'll need to more specific about the data you are copying (e.g. specify the number of columns or an exact range, etc.). In other words, something that will fit in the Range B1 through the last column.


Report •

#2
July 8, 2010 at 07:22:55
Ok, that makes sense, I didn't think of it like that.

All I have to do now is figure out how to specify the range to copy. Obviously I can't specify a fixed range because it will change for each row (although each row is the same length, runnning from column B to column Q). I'm really not sure how to do that so I'll have a dig around the net and see if I can see anything.

Thanks for pointing me in the right direction.


Report •

#3
July 8, 2010 at 07:45:37
Hi,

DerbyDad03 has identified the problem.

Here is a modification that will allow you to choose how many columns to copy, starting at column B and pasting the results to the destination sheet starting at column B.

Option Explicit

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

On Error GoTo ErrHnd

With Worksheets("DC")
    'sets start as B1
    Set rngStart = .Range("B1")
    'sets end
    Set rngEnd = .Range("B" & CStr(Application.Rows.Count)).End(xlUp)

    'loop through cells in column B
    For Each rngCell In Range(rngStart, rngEnd)
        'tests if tab exists
        On Error Resume Next
        If Not Worksheets(rngCell.Text).Name <> "" Then
            On Error GoTo ErrHnd
            'No worksheet of this name - so creates one and copies row
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = rngCell.Text
            rngCell.Resize(1, 10).Copy Destination:=Worksheets(rngCell.Text).Range("B1")
            Else
            On Error GoTo ErrHnd
            'worksheet exists
            'copy row to end of used range
            rngCell.Resize(1, 10).Copy Destination:=Worksheets(rngCell.Text).Range("B1") _
            .Offset(Worksheets(rngCell.Text).UsedRange.Rows.Count, 0)
        End If
    Next rngCell
End With
Exit Sub

'error handler
ErrHnd:
Err.Clear
End Sub

The copy now uses Resize.
rngCell is a single cell in column B
Resize is now enlarging the selection to 1 row and 10 columns - in this case columns B to K

Regards


Report •

Related Solutions

#4
July 12, 2010 at 02:08:30
Thanks Humar (and thanks for the original code as well, I swiped it from one of your earlier posts ;)

The revisions work well, the only issue I have is that the selection needs to include the previous cell as well (the one from column A). At the moment the selection goes from B - K, but I need it to select from A - K (whilst still checking column B for the unique names).

I've tried changing the rngCell.Resize(1, 10) to rngCell.Resize(-1, 10) and even rngCell.Resize(0, 10) but I'm obviously not using the correct format.

I can't really see how to select from column A onwards without adjusting the rngStart and rngEnd parameters, thereby altering the column on which the worksheet names would be based.

Thanks again for your help so far, it really is appreciated.


Report •

#5
July 12, 2010 at 05:13:30
Hi,

The way to do this is to offset from the single rngCell address which is in column B, before resizing the range.

Try this:
rngCell.Offset (0, -1).Resize(1, 11).Copy

I haven't tested this, but I think that it should work.

Regards


Report •


Ask Question