VBA Copy rows to another sheet

Blizzardx23

New Member
Joined
Oct 18, 2016
Messages
20
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:

Tag ID
Item NumberRateDescription
243567742AAJ07541EBoat Sea
453643564A0721421ESki Sea
123452345A0257J25EBoat Sea
675856788A0257J25CYacht Sea
345674577A0D1J124ECar Land
536785683A04152D2ETruck Land
456846657A0D1J17JZBike Land
234523456A222A251EGlider Air
244565436A0D02424EPlane Air
234456425AA1D10A2EPlane 2 Air
765753648AA234FS2
EPlane 2 Air
<colgroup><col width="151" style="width: 113pt;" span="4"> <tbody> </tbody>


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! :)
 

Some videos you may like

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,001
Hello Blizzardx23,

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

Code:
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
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,109,424
Messages
5,528,685
Members
409,830
Latest member
KT50

This Week's Hot Topics

  • Change military grades into rank
    Afternoon all Need help with formula that will change military rank (i.e. 1, 2, 3 into Amn, A1C, SrA). Running IF formula that does not work...
  • VBA COUNTIF SOLUTION
    Hi The following are the errors spread across the several columns from E to Q ie. 13 columns across several sheets with more than 500 rows per...
  • INSERT ROW WITH SPECIFIS TEXT IN A COLUMN
    Hi All! How can identify that that the row to be inserted has to be inserted before 1st row with specific text in column F. If I record the...
  • Auto-Create a monthly Sign in sheet for preschool students
    The image below is what each page looks like. Above is space for the "Child Name" "Month" "Class" School days are obviously Monday-Friday but...
  • VBA vlookup multiple results
    Hi folks, Hopefully someone out there can help. I have a list to vlookup which works (ish). the lookup only picks up the first instance of the...
  • Extract values for earliest/latest times
    I am trying to put together a formula to get the earliest start time, the latest end time from column A for each person in Column B-F without the...
Top