Group and split into seperate excel workbooks 3

[Bilberry]

Hi Friends,
I have a huge spreadsheet (~20.000 rows each time). It looks like as follows:

Column A        B       C   D   E               F       G       H               I               J
Test records	595	595 A	11-XXX-12	3522	A	4-11-2013	05:56:17	3,14
Test records	595	595 A	11-XXX-12	3522	A	4-11-2013	08:29:27	3,14
Test records	595	595 A	11-XXX-12	3522	A	4-11-2013	10:33:55	3,14
Test records	595	595 A	11-XXX-12	3522	A	4-11-2013	11:51:54	3,14
Test records	595	595 A	11-XXX-12	3522	A	4-11-2013	12:49:45	3,14
Test records	595	595 A	11-XXX-12	3522	A	4-11-2013	13:53:35	3,14
Test records	595	595 A	11-XXX-12	3522	A	4-11-2013	14:57:59	3,14
Test records	595	595 A	11-XXX-12	3522	A	5-11-2013	05:24:56	3,14
Test records	595	595 A	11-XXX-12	3522	A	5-11-2013	07:44:06	3,14
Test records	595	595 A	11-XXX-12	3522	A	5-11-2013	08:37:08	3,14
Test records	595	595 A	11-XXX-12	3522	A	5-11-2013	10:00:48	3,14
Test records	595	595 A	11-XXX-12	3522	A	5-11-2013	11:59:54	3,14
Test records	595	595 A	11-XXX-12	3522	A	6-11-2013	05:40:48	3,14
Test recordss	595	595 A	11-XXX-13	3523	A	6-11-2013	08:39:37	3,14
Test recordss	595	595 A	11-XXX-13	3523	A	6-11-2013	10:06:36	3,14
Test recordss	595	595 A	11-XXX-13	3523	A	7-11-2013	05:25:56	3,14
Test recordss	595	595 A	11-XXX-13	3523	A	7-11-2013	07:47:20	3,14

I need to group by column E and split these records into seperate workbooks. In this example i want to get two workbooks with the names:
11-XXX-12.xls
11-XXX-13.xls

and containing only the records which belongs to column E.

Anybody idea how to setup this?
A star for the golden solution!

 

[SkipVought]

hi,

Not a particularly big spreadsheet. Is this an on-going task, like every week or every month?

Why no headings? A proper table of data ought to have headings.

Assuming headings, 1) set the AutoFilter and select the first value in column E, 2) Select ALL, 3) COPY, 4) in the new workbook/sheet1 select A1, right-click and select Paste Special -- VALUES -- OK 5) Save & Close.

Turn on your macro recorder and record doing that process and then this recorded macro can be modified to customize to your particular requirements.

Post back with your recorded code for further help.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Bilberry]

Hi Skip,
Thanks a lot for your quick reply.

We need to do this once a month, thats the reason why i want to have a macro. The columns within the workbook/excel sheet have headers. Below the macro what i have recorded:

Sub Macro1()

    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$H$19189").AutoFilter Field:=4, Criteria1:= _
        "11-XXX-12"
    Range("A1:H19189").Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:="C:\11-XXX-12.xls", _
        FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

Skip, how can i automate this, especially: filtering the values and select the appropriate ranges and save it into seperate files?

Thanks a lot!

 

[SkipVought]

Got some questions.

What version Excel are you running?

Just curious: what's the reason for spawning separate workbooks?

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[SkipVought]

I still need to know the answers to the questions in the previous post.

But here's a process you might consider. The workbook you will code in will be your dashboard.

Each month you will run a procedure to IMPORT new source data into a Source sheet. So far we know nothing about your source data.

Then you will run a procedure to LIST the unique values in column 4 in a List sheet.

Then you will run a procedure to LOOP thru the List, filter the Source ased on each List value, COPY the visible cells to a new workbook, SAVE the workbook using the List name and CLOSE the workbook.

So additionally, I'll need to know what your source data is and how the data is made available to you.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Bilberry]

Hi Skip,
Im running Excel 2007 but will use 2013 for this solution. We get the data (=Excel workbook) from our partner and we will add this information (the seperate/extracted excel file) as an attachment with the invoice. Your procedure is Okey. I was thinking about one "shared" macro, so we can use it when receiving a new file. Maybe there are better solutions for this, for example the use of Office apps 2013. But i havent knowledge about this and hope you can advice me....

Rgrds,

 

[SkipVought]

Okay. Well here's your first macro customized. You'll need to record at least 2 more: one for IMPORT via Data > Get External Data > From Other Sources > From Microsoft Query and one to generate a list of unique values for column 4 in a sheet named List. We need to know what the column 4 heading is.

Sub FilterAndSave(sFileName As String)
    With Sheets("Source")
   
        If .AutoFilter Is Nothing Then .Cells(1, 1).AutoFilter
        
        With .Cells(1, 1).CurrentRegion
            .AutoFilter Field:=4, Criteria1:=sFileName
            .SpecialCells(xlCellTypeVisible).Copy
        End With
        
        With Workbooks.Add
            .Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            Application.CutCopyMode = False

            Application.DisplayAlerts = False
            .SaveAs Filename:="C:\" & sFileName & ".xls", _
                FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
                ReadOnlyRecommended:=False, CreateBackup:=False
            .Close
            Application.DisplayAlerts = True
        End With
    End With
End Sub

The overall process might look like this

Sub Main()
    Dim r As Range
    
    ImportData
    
    CreateList
    
    For Each r In Sheets("List").Range("Head4")
        FilterAndSave r.Value
    Next
    
    Sheets("Source").ShowAllData
End Sub

You've already recorded the basis for FilterAndSave. You still need to record the ImportData and CreateList.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Bilberry]

Hi Skip,
I will follow your instructions. See below the recording for the ImportData sub:

 With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "ODBC;DSN=Excel Files;DBQ=C:\nov 2013.xls;DefaultDir=C:;DriverId=1046;MaxBufferSize=2048;PageTimeout=5;" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = 0
        .CommandText = Array( _
        "SELECT Qr.Name1, Qr.BCode, Qr.tcode, Qr.Kent, Qr.Trsp, Qr.`E-Lbl`, Qr.Dtm, Qr.Time1" & Chr(13) & "" & Chr(10) & "FROM `C:\nov 2013.xls`.Qr Qr" _
        )
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "Table_Query_from_Excel_Files"
        .Refresh BackgroundQuery:=False
    End With

The filename will change every month, how can I make it generic? The heading of Column 4 is "Kent". Could you also please assist me on the creation of the CreateList sub?

Thanks in advance.

 

[SkipVought]

hi,

Here's your Import procedure.

What happens you ADD a ListObject/Querytable only ONE TIME. Then we will simply modify the Path/DB 9workbook name sach month and REFRESH the querytable.

Sub Import()
    Dim sPath As String, sDB As String, sConn As String, sSQL As String
    
    sPath = "C:"
    
    sDB = "nov 2013.xls"
    
    sConn = "ODBC;DSN=Excel Files;"
    sConn = sConn & "DBQ=" & sPath & "\" & sDB & ";"
    sConn = sConn & "DefaultDir=" & sPath & ";"
    sConn = sConn & "DriverId=1046;MaxBufferSize=2048;PageTimeout=5;"
    
    sSQL = "SELECT"
    sSQL = sSQL & "  Qr.Name1"
    sSQL = sSQL & ", Qr.BCode"
    sSQL = sSQL & ", Qr.tcode"
    sSQL = sSQL & ", Qr.Kent"
    sSQL = sSQL & ", Qr.Trsp"
    sSQL = sSQL & ", Qr.`E-Lbl`"
    sSQL = sSQL & ", Qr.Dtm"
    sSQL = sSQL & ", Qr.Time1"
    sSQL = sSQL & vbLf
    sSQL = sSQL & "FROM `" & sPath & "\" & sDB & "`.Qr"
   
    With ActiveSheet.ListObjects.QueryTable
        .Connection = sConn
        .CommandText = sSQL
        .Refresh BackgroundQuery:=False
    End With
End Sub

For the unique list, record COPY column 4, activate the List sheet and PASTE in A1. Data > Data Tools > Remove duplicates (has headings) , Formauls > Defined Names > Create from selection -- TOP row

Post back with your recorded code.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Bilberry]

Hi Skip,
Thanks a lot! I get an "Run time error 438: Object doesn't support the property or method" error on the line:

With ActiveSheet.ListObjects.QueryTable

Any idea?

 

[SkipVought]

Duh, what was I thinking!!!

With ActiveSheet.ListObjects(1).QueryTable

ListObjects is a collection. Happens there's only ONE on your sheet.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Bilberry]

Hi Skip,
Now i get a subscript out of range error on the same line. After Googling i found: Link

Do we need to use a set command?

 

[SkipVought]

Is the Sourse sheet activated?


Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Bilberry]

Yes...

 

[SkipVought]

Please post the code that you're using.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Bilberry]

Hi Skip,
Im using exactly the code as above. Im testing it in Excel 2013, may that be the issue?

Sub Import()
    Dim sPath As String, sDB As String, sConn As String, sSQL As String
    
    sPath = "C:"
    
    sDB = "nov 2013.xls"
    
    sConn = "ODBC;DSN=Excel Files;"
    sConn = sConn & "DBQ=" & sPath & "\" & sDB & ";"
    sConn = sConn & "DefaultDir=" & sPath & ";"
    sConn = sConn & "DriverId=1046;MaxBufferSize=2048;PageTimeout=5;"
    
    sSQL = "SELECT"
    sSQL = sSQL & "  Qr.Name1"
    sSQL = sSQL & ", Qr.BCode"
    sSQL = sSQL & ", Qr.tcode"
    sSQL = sSQL & ", Qr.Kent"
    sSQL = sSQL & ", Qr.Trsp"
    sSQL = sSQL & ", Qr.`E-Lbl`"
    sSQL = sSQL & ", Qr.Dtm"
    sSQL = sSQL & ", Qr.Time1"
    sSQL = sSQL & vbLf
    sSQL = sSQL & "FROM `" & sPath & "\" & sDB & "`.Qr"
   
    With ActiveSheet.ListObjects(1).QueryTable
        .Connection = sConn
        .CommandText = sSQL
        .Refresh BackgroundQuery:=False
    End With
End Sub

 

[SkipVought]

Did you delete the original import data?

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Bilberry]

Hi Skip,
Yes, i want to test the sub again, is that the problem? Now i have an empty sheet. Should i start with the old data?

 

[SkipVought]

When you did the first IMPORT using the process I outlined for you, you placed a ListObject with a QueryTable on you sheet. My code assumes that it's still there.

So run the Marco you recorded, or go thru the process again.

THEN run my procedure.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Bilberry]

Ok Skip you're right, sorry for that..

Now im going to work for the unique list part. I will post the recording here. Thanks again for the support...