Separate large data set onto multiple tabs

[crimsonexcel]

Hi,

I have a large data set (150,000 rows). Each row has 16 columns. I need to separate this data set onto separate tabs based on the text description in column E.

For example there may be 2,000 rows with a description like "Swedish actions in the second world war" I need for excel to recognize the country in the description "Swedish" and pull all rows like this to a new tab in the document called "Swedish". I actually already have the tabs created (about 50 countries) but realize it may be easier to start from scratch.

To further the example, the next 8,000 rows might have titles like "British icons in the 18th century" or "British revolutions and their outcomes". These 50,000 rows may have different descriptions but they are all common in that they start with "British" Again, would need to pull this data to a new tab called "British".

It looks like the first word of every description line is in fact the country if that is at all helpful.

To slightly complicate things, I have around 60 excel files that are all 500,000 rows and need to be sorted this way. Ideally I could drop a master data list (i.e. 1 file) into the first tab of a master document with all of these tabs and have it sort into each tab. I would then repeat this with the next file so that in the end, I have one master file that has everything sorted into tabs (with data collected from all 60 excel files)

Obviously realize I will probably need to do some manual labor to make this happen, just trying to cut my work time down from weeks to days or hours.

Any help would be much appreciated. I have not posted before, so please let me know if you need further information.

Thanks!

 

[crimsonexcel]

So it looks like 8740 is actually the first row for "Argentine". All of the rows before it were a country that was not on the list.

 

[MrKowz]

I think I figured out the problem. It is checking if the sheet exists in the wrong workbook!

Public Sub CrimsonExcel()
Dim i               As Long, _
    LR              As Long, _
    LR2             As Long, _
    overflowcount   As Long, _
    x               As Variant, _
    CountryNames    As Variant, _
    wbMaster        As Workbook, _
    wsMaster        As Worksheet, _
    wbsource        As Workbook, _
    wsSource        As Worksheet, _
    fPath           As String, _
    fName           As String, _
    overflowbool    As Boolean
    
    
' Initial Variable Definitions
CountryNames = Array("Argentine", "Australian", "Austrian", "Belgian", "Brazilian", "Bulgarian", _
                     "Croatian", "Cypriot", "Czech", "Danish", "Dutch", "English", "Finnish", _
                     "French", "German", "Greek", "Hungarian", "Irish", "Italian", "Japanese", _
                     "Mexican", "Northern Ireland", "Norwegian", "Polish", "Portuguese", "Romanian", _
                     "Russian", "Scottish", "Slovakian", "Slovenian", "Spanish", "Swedish", "Swiss", _
                     "Turkish", "Ukranian", "UnitedStates", "Welsh")
Set wbMaster = ActiveWorkbook
Set wsMaster = wbMaster.ActiveSheet
Application.ScreenUpdating = False
' Create a worksheet for each country name.
For i = LBound(CountryNames) To UBound(CountryNames)
    If Not WorksheetExists(CountryNames(i) & " (1)") Then
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = CountryNames(i) & " (1)"
        wsMaster.Rows(1).Copy Destination:=Sheets(CountryNames(i) & " (1)").Range("A1")
    End If
Next i
'
fPath = wbMaster.Path
fName = dir(fPath & "\" & "*.xls")
Do While Len(fName) > 0
    If fName <> wbMaster.Name Then
        Set wbsource = Workbooks.Open(fPath & "\" & fName)
        Set wsSource = wbsource.ActiveSheet
[COLOR=red][B]        wsMaster.Activate
[/B][/COLOR]        LR = wsSource.Range("E" & Rows.Count).End(xlUp).row
        ' Loop through column E and place rows in corresponding workbooks
        For i = 1 To LR
            overflowcount = 1
            Application.StatusBar = "Currently moving row " & i & " of " & LR & " in " & fName
            x = Application.Match(Left(wsSource.Range("E" & i).Value, InStr(wsSource.Range("E" & i).Value & " ", " ") - 1), CountryNames, 0)
            If Not IsError(x) Then
                Do
                    If Not WorksheetExists(CountryNames(x - 1) & " (" & overflowcount & ")") Then
                        Sheets.Add After:=Sheets(CountryNames(x - 1) & " (" & overflowcount - 1 & ")")
                        ActiveSheet.Name = CountryNames(x - 1) & " (" & overflowcount & ")"
                        wsMaster.Rows(1).Copy Destination:=Sheets(CountryNames(x - 1) & " (" & overflowcount & ")")
                    End If
                    With wbMaster.Sheets(CountryNames(x - 1) & " (" & overflowcount & ")")
                        LR2 = .Range("E" & .Rows.Count).End(xlUp).row + 1
                        If LR2 < 1048500 Then
                            wsSource.Rows(i).Cut Destination:=.Range("A" & LR2)
                            overflowbool = False
                        Else
                            overflowbool = True
                            overflowcount = overflowcount + 1
                        End If
                    End With
                Loop Until overflowbool = False
            End If
        Next i
    End If
Loop
With Application
    .ScreenUpdating = True
    .StatusBar = False
End With
End Sub

 

[vinkhera]

Hello All,

I am new to this forum. Seems like a great forum to learn. I have created a Macro. My purpose to create this macro was to click a button that would ask you to select a folder from a browse window and once you select the folder, it would copy all the spreadsheets and put those spreadsheets on to a different tab where I click my button.

Then I created another macro so I could merge all the tabs in to one tab. I am almost at the end.

However this is what I need at this point.

I need the macro to only choose first tab which is called 'Losses' from each spreadsheet within a folder and spit it on to one spreadsheet regardless regardless of the number of spreadsheet there are within a folder. Currently, the macro copies all tabs from the spreadhseets and spits those in to one sheet.

See my code below:

Option Explicit

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszpath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
As Long

Public Type BrowseInfo
hOwner As Long
pIDLRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Function GetDirectory(Optional msg) As String
On Error Resume Next
Dim bInfo As BrowseInfo
Dim path As String
Dim r As Long, x As Long, pos As Integer

'Root folder = Desktop
bInfo.pIDLRoot = 0&

'Title in the dialog
If IsMissing(msg) Then
bInfo.lpszTitle = "G:\PGMS\CLAIMSRPT\2011\2011 01"
Else
bInfo.lpszTitle = msg
End If

'Type of directory to return
bInfo.ulFlags = &H1

'Display the dialog
x = SHBrowseForFolder(bInfo)

'Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim ws As Worksheet
Dim ThisWB As String

ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
FileName = Dir(path & "\*.xls", vbNormal)
Do Until FileName = ""
If FileName <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
For Each ws In Wkb.Worksheets
Set LastCell = ws.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next ws
Wkb.Close False
End If
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True

Set Wkb = Nothing
Set LastCell = Nothing
End Sub
---------------------------------------------
Here is my code to merge all tabs in to one tab once the first macro spits all spreadsheets to different tabs.

Sub Mergetabs()
'========================================================================
' THIS MERGES "VALUES" AND FORMATTING OF ALL SHEETS IN WORKBOOK
' ONTO A NEW SHEET ADDED AS FIRST SHEET
'========================================================================
Dim ws As Worksheet
Sheets.Add Before:=Sheets(1)
Sheets(1).Activate
ActiveSheet.UsedRange.Offset(0).Clear
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ActiveSheet.Name Then
ws.UsedRange.Copy
With Range("A65536").End(xlUp).Offset(1, 0)
.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End With
End If
Next
End Sub
---------------------------------------------------------
Any help would be greatly appreciated.

 

[MrKowz]

Welcome to the forums, Vinkhera!

Instead of posting in someone else's thread, try making your own. That way you can get replies and help focused on your issue.

 

[vinkhera]

My apologies...will do so but if someone from this thread can offer any help...feel free to do so.

thanks,
Vin

 

[crimsonexcel]

I think I figured out the problem. It is checking if the sheet exists in the wrong workbook!

Public Sub CrimsonExcel()
Dim i               As Long, _
    LR              As Long, _
    LR2             As Long, _
    overflowcount   As Long, _
    x               As Variant, _
    CountryNames    As Variant, _
    wbMaster        As Workbook, _
    wsMaster        As Worksheet, _
    wbsource        As Workbook, _
    wsSource        As Worksheet, _
    fPath           As String, _
    fName           As String, _
    overflowbool    As Boolean
    
    
' Initial Variable Definitions
CountryNames = Array("Argentine", "Australian", "Austrian", "Belgian", "Brazilian", "Bulgarian", _
                     "Croatian", "Cypriot", "Czech", "Danish", "Dutch", "English", "Finnish", _
                     "French", "German", "Greek", "Hungarian", "Irish", "Italian", "Japanese", _
                     "Mexican", "Northern Ireland", "Norwegian", "Polish", "Portuguese", "Romanian", _
                     "Russian", "Scottish", "Slovakian", "Slovenian", "Spanish", "Swedish", "Swiss", _
                     "Turkish", "Ukranian", "UnitedStates", "Welsh")
Set wbMaster = ActiveWorkbook
Set wsMaster = wbMaster.ActiveSheet
Application.ScreenUpdating = False
' Create a worksheet for each country name.
For i = LBound(CountryNames) To UBound(CountryNames)
    If Not WorksheetExists(CountryNames(i) & " (1)") Then
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = CountryNames(i) & " (1)"
        wsMaster.Rows(1).Copy Destination:=Sheets(CountryNames(i) & " (1)").Range("A1")
    End If
Next i
'
fPath = wbMaster.Path
fName = dir(fPath & "\" & "*.xls")
Do While Len(fName) > 0
    If fName <> wbMaster.Name Then
        Set wbsource = Workbooks.Open(fPath & "\" & fName)
        Set wsSource = wbsource.ActiveSheet
[COLOR=red][B]        wsMaster.Activate
[/B][/COLOR]        LR = wsSource.Range("E" & Rows.Count).End(xlUp).row
        ' Loop through column E and place rows in corresponding workbooks
        For i = 1 To LR
            overflowcount = 1
            Application.StatusBar = "Currently moving row " & i & " of " & LR & " in " & fName
            x = Application.Match(Left(wsSource.Range("E" & i).Value, InStr(wsSource.Range("E" & i).Value & " ", " ") - 1), CountryNames, 0)
            If Not IsError(x) Then
                Do
                    If Not WorksheetExists(CountryNames(x - 1) & " (" & overflowcount & ")") Then
                        Sheets.Add After:=Sheets(CountryNames(x - 1) & " (" & overflowcount - 1 & ")")
                        ActiveSheet.Name = CountryNames(x - 1) & " (" & overflowcount & ")"
                        wsMaster.Rows(1).Copy Destination:=Sheets(CountryNames(x - 1) & " (" & overflowcount & ")")
                    End If
                    With wbMaster.Sheets(CountryNames(x - 1) & " (" & overflowcount & ")")
                        LR2 = .Range("E" & .Rows.Count).End(xlUp).row + 1
                        If LR2 < 1048500 Then
                            wsSource.Rows(i).Cut Destination:=.Range("A" & LR2)
                            overflowbool = False
                        Else
                            overflowbool = True
                            overflowcount = overflowcount + 1
                        End If
                    End With
                Loop Until overflowbool = False
            End If
        Next i
    End If
Loop
With Application
    .ScreenUpdating = True
    .StatusBar = False
End With
End Sub

Looks like I may just be running into some processing power issues as this point. It worked but took about a half our for one file. I will either let it run over the weekend with all the files or may use the first script to do some sort of combination of macro and manual. Either way, this has been enormously helpful and I really appreciate all the time you have spent helping me.

Thanks again!

 

[MrKowz]

Looks like I may just be running into some processing power issues as this point. It worked but took about a half our for one file. I will either let it run over the weekend with all the files or may use the first script to do some sort of combination of macro and manual. Either way, this has been enormously helpful and I really appreciate all the time you have spent helping me.

Thanks again!

Depending on how many rows your file has, that is to be expected. Excel 2007 actually took a drastic hit in VBA performance from Excel 2003, however the tradeoff is a lot of other inherant functionality.