Solved Filter and copy to to spreadsheet based on ID

June 22, 2017 at 08:07:42
Specs: Mac OS
Hi,

Im a newbie in excel macros, trying to program a macro that will sort data based on driver id, and then copy it to a new spreadsheet named after the driver id. And then further manipulate data in the newly created spreadsheet to calculate their wage and tax and so on.

Here´s the original file we receive at the end of the month, with the first few lines:

Løyve Reg. nr. Org. nr. Sjåførnr. SwAu2Pc SwAu2Tax Serienr. Skiftnr. Km mellom skift Start dato Start tid Start total innkjørt Start total MVA Start total km Stopp dato Stopp tid Stopp total innkjørt Stopp total MVA Stop total km Antall turer Km total Km besatt Km opptatt Innkjørt rekv. Lav sats Innkjørt kred. Lav sats Innkjørt kont. Lav sats Innkjørt total Lav sats Til oppgjør Lav sats Tillegg rekv. Lav sats Utlegg rekv. Lav sats Ekstra rekv. Lav sats VIP rabatt rekv. Lav sats Kon. pris rekv. Lav sats Tillegg kred. Lav sats Utlegg kred. Lav sats Ekstra kred. Lav sats VIP rabatt kred. Lav sats Kon. pris kred. Lav sats Tillegg kont. Lav sats Utlegg kont. Lav sats Ekstra kont. Lav sats VIP rabatt kont. Lav sats Kon. pris kont. Lav sats Bomtur kont. Lav sats Innkjørt rekv. Høy sats Innkjørt kred. Høy sats Innkjørt kont. Høy sats Innkjørt total Høy sats Til oppgjør Høy sats Tillegg rekv. Høy sats Utlegg rekv. Høy sats Ekstra rekv. Høy sats VIP rabatt rekv. Høy sats Kon. pris rekv. Høy sats Tillegg kred. Høy sats Utlegg kred. Høy sats Ekstra kred. Høy sats VIP rabatt kred. Høy sats Kon. pris kred. Høy sats Tillegg kont. Høy sats Utlegg kont. Høy sats Ekstra kont. Høy sats VIP rabatt kont. Høy sats Kon. pris kont. Høy sats Bomtur kont. Høy sats Innkjørt rekv. 0% Innkjørt kred. 0% Innkjørt kont. 0% Innkjørt total 0% Til oppgjør 0% Tillegg rekv. 0% Utlegg rekv. 0% Ekstra rekv. 0% VIP rabatt rekv. 0% Kon. pris rekv. 0% Tillegg kred. 0% Utlegg kred. 0% Ekstra kred. 0% VIP rabatt kred. 0% Kon. pris kred. 0% Tillegg kont. 0% Utlegg kont. 0% Ekstra kont. 0% VIP rabatt kont. 0% Kon. pris kont. 0% Bomtur kont. 0% Tips (kont.) Tips (kred.) Lønnsgrunnlag Faktisk kont. Tips (kont.) 2 Drivstoff Drivstoff (liter) Vask Rekvisita Bilag 25 Bilag 14 Bilag 8 Bilag 0 Ureg. rekv. Forskudd Netto 1 Kasse start dato Kasse start tid Kasse ved start Kasse tilført Netto 2 Kasse ved ****t Kasse opptelling Kasse differanse Kasse stopp dato Kasse stopp tid Effektiv timer Effektiv minutter
Y82 ZP45758 NO997153243MVA 134368 169 1.3.3 2001739 3 031 0,00 01.05.2017 09.58 8588 429,00 674 599,86 549 433,90 01.05.2017 21.15 8591 767,00 674 903,32 549 603,00 6 169,00 0,00 112,30 764,00 2 574,00 0,00 3 338,00 3 338,00 0,00 0,00 0,00 0,00 0,00 17,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 3 034,55 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0 0,00 0,00 0,00 0,00 0,00 0,00 0,00 01.05.2017 21.15 9 32
Y82 ZP45758 NO997153243MVA 134860 169 1.3.3 2001739 3 032 13,00 02.05.2017 06.58 8591 767,00 674 903,32 549 615,90 02.05.2017 16.39 8595 208,00 675 216,12 549 798,50 12 182,60 0,00 140,00 145,00 3 031,00 265,00 3 441,00 3 176,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 3 128,18 265,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0,00 0 265,00 0,00 0,00 265,00 265,00 0,00 265,00 02.05.2017 16.39 9 39

I want the sorting to be based on column D (Sjåførnr.) and the new sheets to be named 134368 and 134860 and so on. Anyone now how to solve this?

And if I want to manipulate this further can I just record a macro, and then copy this into the script so it will do the same with all drivers?


Thank you


See More: Filter and copy to to spreadsheet based on ID

Reply ↓  Report •

✔ Best Answer
July 3, 2017 at 01:40:45
Update... ok having your workbook helped, I have updated the code and sent you the complete WB. I also found an error in my original code so here is the updated working version.

Dim Unique() As Variant
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
Dim NumUnique As Long
Dim bCell As Range
Dim FreeRow As Long
    
Public Sub SortSheet()
    
    Sheets("Skift").Range("A1", Sheets("Skift").Range("D" & Rows.Count).End(xlUp).Address).Sort Key1:=[D1], _
    Order1:=xlAscending, Header:=xlYes
    
    CreateUniqueSheets
End Sub

Sub CreateUniqueSheets()
    Dim ShName As String
    
    UniqueItems Sheets("Skift").Range("D2", Sheets("Skift").Range("D" & Rows.Count).End(xlUp))
        
        For i = 1 To NumUnique
        
            For ws = 1 To Worksheets.Count
                
                If Worksheets(ws).Name <> Unique(i) Then
                    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = Unique(i)
                    ShName = Unique(i)
                    
                    For Each bCell In Range("D2", Range("D" & Rows.Count).End(xlUp))
                        If bCell = ShName Then
     
                            bCell.EntireRow.Copy
                           
                            FreeRow = Worksheets(ShName).Range("A" & Rows.Count).End(xlUp).Row
                            
                            If Worksheets(ShName).Range("A1") = vbNullString Then
                                
                                Worksheets(ShName).Range("A1").PasteSpecial xlPasteValues
                            Else
                            
                                Worksheets(ShName).Range("A" & FreeRow + 1).PasteSpecial xlPasteValues
                           End If
                              
                        End If
                    Next bCell
                    
                    Exit For
                End If
            
            Next ws
         
        Next i

End Sub
    
Function UniqueItems(ArrayIn) As Variant

    NumUnique = 0

    For Each Element In ArrayIn
        FoundMatch = False

        For i = 1 To NumUnique
            If Element = Unique(i) Then
                FoundMatch = True
                Exit For
            End If
        Next i
AddItem:

        If Not FoundMatch And Not IsEmpty(Element) Then
            NumUnique = NumUnique + 1
            ReDim Preserve Unique(NumUnique)
            Unique(NumUnique) = Element
        End If
    Next Element

End Function





#1
June 23, 2017 at 02:56:32
Kyrre85,

There is no way we can decipher that above mess, please use the pre tags to present your data in a much more digestable way. Read the link below

https://www.computing.net/howtos/sh...

Please ensure you include column headers and row numbers.


Reply ↓  Report •

#2
June 23, 2017 at 03:15:08
Off course, I´ll try :)

Løyve	Reg. nr.	Org. nr.	Sjåførnr.	SwAu2Pc	SwAu2Tax	Serienr.	Skiftnr.	Km mellom skift	Start dato	Start tid	Start total innkjørt	Start total MVA	Start total km	Stopp dato	Stopp tid	Stopp total innkjørt	Stopp total MVA	Stop total km	Antall turer	Km total	Km besatt	Km opptatt	Innkjørt rekv. Lav sats	Innkjørt kred. Lav sats	Innkjørt kont. Lav sats	Innkjørt total Lav sats	Til oppgjør Lav sats	Tillegg rekv. Lav sats	Utlegg rekv. Lav sats	Ekstra rekv. Lav sats	VIP rabatt rekv. Lav sats	Kon. pris rekv. Lav sats	Tillegg kred. Lav sats	Utlegg kred. Lav sats	Ekstra kred. Lav sats	VIP rabatt kred. Lav sats	Kon. pris kred. Lav sats	Tillegg kont. Lav sats	Utlegg kont. Lav sats	Ekstra kont. Lav sats	VIP rabatt kont. Lav sats	Kon. pris kont. Lav sats	Bomtur kont. Lav sats	Innkjørt rekv. Høy sats	Innkjørt kred. Høy sats	Innkjørt kont. Høy sats	Innkjørt total Høy sats	Til oppgjør Høy sats	Tillegg rekv. Høy sats	Utlegg rekv. Høy sats	Ekstra rekv. Høy sats	VIP rabatt rekv. Høy sats	Kon. pris rekv. Høy sats	Tillegg kred. Høy sats	Utlegg kred. Høy sats	Ekstra kred. Høy sats	VIP rabatt kred. Høy sats	Kon. pris kred. Høy sats	Tillegg kont. Høy sats	Utlegg kont. Høy sats	Ekstra kont. Høy sats	VIP rabatt kont. Høy sats	Kon. pris kont. Høy sats	Bomtur kont. Høy sats	Innkjørt rekv. 0%	Innkjørt kred. 0%	Innkjørt kont. 0%	Innkjørt total 0%	Til oppgjør 0%	Tillegg rekv. 0%	Utlegg rekv. 0%	Ekstra rekv. 0%	VIP rabatt rekv. 0%	Kon. pris rekv. 0%	Tillegg kred. 0%	Utlegg kred. 0%	Ekstra kred. 0%	VIP rabatt kred. 0%	Kon. pris kred. 0%	Tillegg kont. 0%	Utlegg kont. 0%	Ekstra kont. 0%	VIP rabatt kont. 0%	Kon. pris kont. 0%	Bomtur kont. 0%	Tips (kont.)	Tips (kred.)	Lønnsgrunnlag	Faktisk kont.	Tips (kont.) 2	Drivstoff	Drivstoff (liter)	Vask	Rekvisita	Bilag 25	Bilag 14	Bilag 8	Bilag 0	Ureg. rekv.	Forskudd	Netto 1	Kasse start dato	Kasse start tid	Kasse ved start	Kasse tilført	Netto 2	Kasse ved slutt	Kasse opptelling	Kasse differanse	Kasse stopp dato	Kasse stopp tid	Effektiv timer	Effektiv minutter
Y82	ZP45758	NO997153243MVA	134368	 169	1.3.3	2001739	3 031	 0,00	01.05.2017	09.58	8588 429,00	674 599,86	549 433,90	01.05.2017	21.15	8591 767,00	674 903,32	549 603,00	 6	 169,00	 0,00	 112,30	 764,00	2 574,00	 0,00	3 338,00	3 338,00	 0,00	 0,00	 0,00	 0,00	 0,00	 17,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	3 034,55	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0	 0,00			 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	01.05.2017	21.15	 9	 32
Y82	ZP45758	NO997153243MVA	134860	 169	1.3.3	2001739	3 032	 13,00	02.05.2017	06.58	8591 767,00	674 903,32	549 615,90	02.05.2017	16.39	8595 208,00	675 216,12	549 798,50	 12	 182,60	 0,00	 140,00	 145,00	3 031,00	 265,00	3 441,00	3 176,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	3 128,18	 265,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0,00	 0	 265,00			 0,00	 0,00	 265,00	 265,00	 0,00	 265,00	02.05.2017	16.39	 9	 39


It wasn't´t perfect, but the most important part is visible, the column D, 134368 and 134860.

message edited by Kyrre85


Reply ↓  Report •

#3
June 23, 2017 at 03:29:53
Here´s the original file shared from onedrive:

https://1drv.ms/x/s!AjeTZ75yISqrhLM...


Reply ↓  Report •

Related Solutions

#4
June 26, 2017 at 05:29:25
You can try this code.

assumptions
- You unique id's are in column D

You will need to run the code from Sub SortSheet. The code will

Sort the data on column D
Create unique sheet names from column D
Copy and paste all data pertaining to the sheet names


Dim Unique() As Variant
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
Dim NumUnique As Long
Dim bCell As Range
Dim FreeRow As Long
    
Public Sub SortSheet()
    
    Sheet1.Range("A1", Range("D" & Rows.Count).End(xlUp).Address).Sort Key1:=[D1], _
    Order1:=xlAscending, Header:=xlYes
    
    CreateUniqueSheets
End Sub


Sub CreateUniqueSheets()
    Dim ShName As String
    
    UniqueItems Range("D2:D9")
        
        For i = 1 To NumUnique
        
            For ws = 1 To Worksheets.Count
                
                If Worksheets(ws).Name <> Unique(i) Then
                    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = Unique(i)
                    ShName = Unique(i)
                    
                    For Each bCell In Range("D2", Range("D" & Rows.Count).End(xlUp))
                        If bCell = ShName Then
     
                            bCell.EntireRow.Copy
                           
                            FreeRow = Worksheets(ShName).Range("A" & Rows.Count).End(xlUp).Row
                            
                            If Worksheets(ShName).Range("A1") = vbNullString Then
                                
                                Worksheets(ShName).Range("A1").PasteSpecial xlPasteValues
                            Else
                            
                                Worksheets(ShName).Range("A" & FreeRow + 1).PasteSpecial xlPasteValues
                           End If
                              
                        End If
                    Next bCell
                    
                    Exit For
                End If
            
            Next ws
         
        Next i

End Sub
    
Function UniqueItems(ArrayIn) As Variant

    NumUnique = 0

    For Each Element In ArrayIn
        FoundMatch = False

        For i = 1 To NumUnique
            If Element = Unique(i) Then
                FoundMatch = True
                Exit For
            End If
        Next i
AddItem:

        If Not FoundMatch And Not IsEmpty(Element) Then
            NumUnique = NumUnique + 1
            ReDim Preserve Unique(NumUnique)
            Unique(NumUnique) = Element
        End If
    Next Element

End Function


message edited by AlwaysWillingToLearn


Reply ↓  Report •

#5
June 27, 2017 at 14:50:20
Thank you so much for taking the time and effort to help!

I tried to run the code, but it gives me runtime error 424, on line 9, Sheet1.Range("A1", Range("D" & Rows.Count).End(xlUp).Address).Sort Key1:=[D1], _

Do you know what the problem is?

I also noticed that I have two macros, CreateUniqueSheets and SortSheets. I was able to run the CreateUniqueSheets but it only created a sheet for the first two drivers, up to line 9.

Thank you!


Reply ↓  Report •

#6
June 27, 2017 at 17:28:52
Kyrre85:

Why did you mark the thread as Solved (by choosing the Best Answer) when the code offered doesn't work?

Please wait until your issue is completely solved before choosing the Best Answer.

I have reset the Best Answer for this thread.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Reply ↓  Report •

#7
June 28, 2017 at 00:46:17
Not sure why this isn't running, it is working fine for me, perhaps change the reference to sheet1 to whatever sheet you are using?

The aim of the SortSheet code is to sort the data on column D in ascending order, try to run that code by itself without calling CreateSheets

move a few rows around and see if it works

Public Sub SortSheet()
    
    Sheet1.Range("A1", Range("DJ" & Rows.Count).End(xlUp).Address).Sort Key1:=[D2], _
    Order1:=xlAscending, Header:=xlYes

End Sub

Please note the change from D to DJ

Derby,

Maybe you can see something that I am missing?


Reply ↓  Report •

#8
July 3, 2017 at 01:40:45
✔ Best Answer
Update... ok having your workbook helped, I have updated the code and sent you the complete WB. I also found an error in my original code so here is the updated working version.

Dim Unique() As Variant
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
Dim NumUnique As Long
Dim bCell As Range
Dim FreeRow As Long
    
Public Sub SortSheet()
    
    Sheets("Skift").Range("A1", Sheets("Skift").Range("D" & Rows.Count).End(xlUp).Address).Sort Key1:=[D1], _
    Order1:=xlAscending, Header:=xlYes
    
    CreateUniqueSheets
End Sub

Sub CreateUniqueSheets()
    Dim ShName As String
    
    UniqueItems Sheets("Skift").Range("D2", Sheets("Skift").Range("D" & Rows.Count).End(xlUp))
        
        For i = 1 To NumUnique
        
            For ws = 1 To Worksheets.Count
                
                If Worksheets(ws).Name <> Unique(i) Then
                    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = Unique(i)
                    ShName = Unique(i)
                    
                    For Each bCell In Range("D2", Range("D" & Rows.Count).End(xlUp))
                        If bCell = ShName Then
     
                            bCell.EntireRow.Copy
                           
                            FreeRow = Worksheets(ShName).Range("A" & Rows.Count).End(xlUp).Row
                            
                            If Worksheets(ShName).Range("A1") = vbNullString Then
                                
                                Worksheets(ShName).Range("A1").PasteSpecial xlPasteValues
                            Else
                            
                                Worksheets(ShName).Range("A" & FreeRow + 1).PasteSpecial xlPasteValues
                           End If
                              
                        End If
                    Next bCell
                    
                    Exit For
                End If
            
            Next ws
         
        Next i

End Sub
    
Function UniqueItems(ArrayIn) As Variant

    NumUnique = 0

    For Each Element In ArrayIn
        FoundMatch = False

        For i = 1 To NumUnique
            If Element = Unique(i) Then
                FoundMatch = True
                Exit For
            End If
        Next i
AddItem:

        If Not FoundMatch And Not IsEmpty(Element) Then
            NumUnique = NumUnique + 1
            ReDim Preserve Unique(NumUnique)
            Unique(NumUnique) = Element
        End If
    Next Element

End Function




Reply ↓  Report •

#9
July 5, 2017 at 07:26:17
How are you getting on with this?

Reply ↓  Report •

#10
July 7, 2017 at 04:38:10
Hi,

thank you so much for your help. You are the best!
After some testing it works perfectly. But I might be new to this, do you need to copy the code into each spreadsheet in the worksheet it is going to manipulate, or can you store it as a global macro. I´m trying to figure that out. And I also plan to record a macro to further manipulate this to calculate wage and tax etc. Is that possible to incorporate into your code once I have finished recording so that it does the complete job with every sheet in one operation?


Reply ↓  Report •

#11
July 7, 2017 at 05:22:08
You can modify the code so it can process all sheets in one module, this is a more efficient method rather than having code in each module which will be unmanageable.

The code will need to loop through all sheets and do the processing, but obviously if you have sheets that do not need to be processed we can code them out. So many ways to do it but will need to know exactly what you need.

As for the wages calculation yes you can incorporate that in the code, but I wouldn't use a recorded macro, they are inefficient, rather record one and possibly update it, or tell us what you need to do and we can provide a solution;

message edited by AlwaysWillingToLearn


Reply ↓  Report •

#12
July 7, 2017 at 05:43:01
Kyrre85,

If you would like to build your VBA coding skills, may I suggest that you review the tips found in this tutorial:

https://www.computing.net/howtos/sh...

The tutorial contains the word "debugging" in the title, which implies that it's purpose is to find problems with code that does not work, but the techniques can also serve a totally different purpose.

By using the techniques, you can essentially reverse engineer code that you find on the internet, such as what AWTL has offered. I essentially learned how to code in VBA by utilizing the techniques listed in the tutorial. e.g. "Oh, I see! Now I understand what the author is doing with that variable." As you review more and more code on a line-by-line basis, your understanding of VBA will grow rapidly.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Reply ↓  Report •

Ask Question