VBA Copy rows to another sheet

[Blizzardx23]

Hey everyone! Hope everybody is doing well.

I've bee searching around and I've found some threads that are similar to what I'm trying to do but small differences completely change the results.

I have a spreadsheet that is e-mailed to me daily. It has hundreds of lines that need to be separated into 7 or so sheets.

The code needs to find a specific word in "D" column (per row) to determine what sheet it copies that row to.

Example:

[TABLE="width: 452"]
<colgroup><col width="151" style="width: 113pt;" span="4"> <tbody>[TR]
[TD="width: 151, bgcolor: transparent"]Tag ID
[/TD]
[TD="width: 151, bgcolor: transparent"]Item Number[/TD]
[TD="width: 151, bgcolor: transparent"]Rate[/TD]
[TD="width: 151, bgcolor: transparent"]Description[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]243567742[/TD]
[TD="bgcolor: transparent"]AAJ07541[/TD]
[TD="bgcolor: transparent"]E[/TD]
[TD="bgcolor: transparent"]Boat Sea[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]453643564[/TD]
[TD="bgcolor: transparent"]A0721421[/TD]
[TD="bgcolor: transparent"]E[/TD]
[TD="bgcolor: transparent"]Ski Sea[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]123452345[/TD]
[TD="bgcolor: transparent"]A0257J25[/TD]
[TD="bgcolor: transparent"]E[/TD]
[TD="bgcolor: transparent"]Boat Sea[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]675856788[/TD]
[TD="bgcolor: transparent"]A0257J25[/TD]
[TD="bgcolor: transparent"]C[/TD]
[TD="bgcolor: transparent"]Yacht Sea[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]345674577[/TD]
[TD="bgcolor: transparent"]A0D1J124[/TD]
[TD="bgcolor: transparent"]E[/TD]
[TD="bgcolor: transparent"]Car Land[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]536785683[/TD]
[TD="bgcolor: transparent"]A04152D2[/TD]
[TD="bgcolor: transparent"]E[/TD]
[TD="bgcolor: transparent"]Truck Land[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]456846657[/TD]
[TD="bgcolor: transparent"]A0D1J17J[/TD]
[TD="bgcolor: transparent"]Z[/TD]
[TD="bgcolor: transparent"]Bike Land[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]234523456[/TD]
[TD="bgcolor: transparent"]A222A251[/TD]
[TD="bgcolor: transparent"]E[/TD]
[TD="bgcolor: transparent"]Glider Air[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]244565436[/TD]
[TD="bgcolor: transparent"]A0D02424[/TD]
[TD="bgcolor: transparent"]E[/TD]
[TD="bgcolor: transparent"]Plane Air[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]234456425[/TD]
[TD="bgcolor: transparent"]AA1D10A2[/TD]
[TD="bgcolor: transparent"]E[/TD]
[TD="bgcolor: transparent"]Plane 2 Air[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]765753648[/TD]
[TD="bgcolor: transparent"]AA234FS2
[/TD]
[TD="bgcolor: transparent"]E[/TD]
[TD="bgcolor: transparent"]Plane 2 Air[/TD]
[/TR]
</tbody>[/TABLE]


It would read the information above, and move the first line for the Boat to a sheet called "Sea"..then copy the entire line for Yacht to the next line in the "Sea" sheet. Then it'll do the same for anything in Land, Air and any others that we will need to make.

OR...

If there is a way for me to have a Macro that reads what I have in "Air" sheet, it will copy any new (unmatched) Air lines from the updated/daily sheet that I receive. That would actually be best. That action would be based off the Unique Tag ID (Like the last 2 lines in my example...if the 1st "Plane 2 Air" was already listed in the "Air" sheet, it would skip that one.


Thank you everyone in advance!

 

[vcoolio]

Hello Blizzardx23,

Try the following code in a copy of your workbook first:-

Sub CreateSheetsTransferData()

        Dim ar As Variant
        Dim i As Integer
        Dim lr As Long
        Dim ws As Worksheet
        Dim sh As Worksheet

Application.ScreenUpdating = False

Helper

Set sh = Sheet1 '----> Change to suit.
lr = sh.Range("A" & Rows.Count).End(xlUp).Row
sh.Range("E1:E" & lr).AdvancedFilter 2, [P1], , 1 '----> Unique records only.
sh.Range("P2", sh.Range("P" & sh.Rows.Count).End(xlUp)).Sort [P2], 1 '----> Takes care of blank cells from Column E.

ar = sh.Range("P2", sh.Range("P" & sh.Rows.Count).End(xlUp)) '----> Assign to array.

For i = LBound(ar) To UBound(ar) '----> Start the loop
        If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then '----> Check sheet exists.
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = ar(i, 1) '----> Add sheet if False.
        End If
        Set ws = Worksheets(CStr(ar(i, 1))) '----> Assign ws variable to sheet.
        sh.Range("E1:E" & lr).AutoFilter 1, ar(i, 1) '----> Filter.
        sh.[C1].CurrentRegion.Copy
        ws.[a1].PasteSpecial xlPasteValues '----> Transfer the data. Values only.
        ws.Columns.AutoFit
  Next i
    
sh.[E1].AutoFilter
sh.[P:P].Clear
sh.Select

Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Sheets created/data transfer completed!", vbExclamation, "STATUS"

End Sub

Sub Helper()

      Dim c As Range
      Dim lr As Long
      lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
      
For Each c In Sheet1.Range("D2:D" & lr)
      c.Offset(, 1) = Right(c, Len(c) - InStrRev(c, " "))
Next c

End Sub

Its actually two codes with the main one calling the smaller one ("Helper").

The "Helper" code extracts the last part of the descriptions in Column D to Column E (land, sea, air etc....). In the main code, Column P is used to extract the unique values from Column E and then uses these unique values to create sheets (named Land, Sea etc....) and then transfer the relevant rows of data to their individual destination sheets. You'll need to create a named range for Column P first for the unique values. To do this:-

- Click on cell P1.
- Go to the Formulas tab in the ribbon.
- Select "Define Name" in the "Defined Names" group.
- In the New Name dialogue box that appears, type "Extract" (or use a name of your choice) in the name box then click OK.

I've made some notations for you in the main code just to help you understand it a little.

Hence, create a copy of your workbook, delete all sheets except your main data sheet, place the code in a standard module and assign it to a button. Test away!

Following is the link to a sample workbook I've created for you based on the data in your opening post:

http://ge.tt./7guC2su2

I've extended the data down 10K - odd rows. Click on the "RUN" button to see how it works.

I hope that this helps.

Cheerio,
vcoolio.

P.S. Actually use the following link instead.

http://ge.tt./41UG3su2