Parsing a spreadsheet

[depcdivr]

I have a spreadsheet that is 50K+ lines. I need to copy each row and paste the data into a new sheet based on the value of a specific cell in that row. There are potentially 20-25 different values for the cells that I am checking. Therefore I need to create 20-25 new worksheets and sort the data into them.

I am using this code but I am sure there is a more elegant(aka faster) way of doing this sort.

irow=ws.cells(row.count,2).end(xlup).row+1

For X=2 to irow

set ws2=worksheets(ws.cells(x,19).value)
    irow2=ws2.cells(rows.count,2).end(xlup).row+1

ws.range(x & ":" & x).copy
ws2.range(irow2 & ":" & irow2).pastespecial xlpastevalues

next x

Any assistance would be appreciated. Thank you

 

[NdNoviceHlp]

Hi depcdivr. You really didn't provide a lot of info to go with and that code doesn't really look like it would work? What's the starting sheet and where is the data.... where is the specific search cell and the data to be copied? What are the different search values/how to you determine them? Is all the data transfered? What of the remaining data.. leave intact or cut the copied bits out? Place the data where... in new sheets or existing sheets and where in the sheets? That's all I can think of now. HTH. Dave

 

[depcdivr]

OK here is a bit more details. The spreadsheet that I am working with is 27 columns wide and has 50K rows(and growing). In column 19 starting in row 2 there is a name. There can be 20 or so names in that column. I need to take all of the data with one name and migrate that into a new sheet. Then save that sheet as a new workbook.

So what I did was
1) create the new worksheets with the same name as what appears in Column 19
2) copy the header(row 1) to each of them
3) do a for/next to go through the data in the original spreadsheet, ready column 19 and copy that line into the last line of the worksheet with that name.
4) move that spreadsheet into a new workbook and save it using a name based on the date and sheet name.

I need to leave the original spreadsheet with all of the data intact as other people utilize it.

My whole code is attached below. Everything else works fine but the step # 3 is taking 3-4 hours to run.

Sub Parse_data_by_rep()
Dim WS_Count As Integer
Dim I As Integer

'sets original spreadsheet with data being copied and counts rows'
Set ws = Sheets("Data")
irow = ws.Cells(Rows.Count, 2).End(xlUp).Row

' Generates the new workbooks'
Sheets.Add(after:=Sheets("Data")).Name = "C & N Associates"
Sheets.Add(after:=Sheets("Data")).Name = "CFE MacIinnis"
Sheets.Add(after:=Sheets("Data")).Name = "Electro-Design"
Sheets.Add(after:=Sheets("Data")).Name = "Electromark"
Sheets.Add(after:=Sheets("Data")).Name = "English Tech. Sales"
Sheets.Add(after:=Sheets("Data")).Name = "Glen White Assoc."
Sheets.Add(after:=Sheets("Data")).Name = "Inter-Comm"
Sheets.Add(after:=Sheets("Data")).Name = "Jackson Harper"
Sheets.Add(after:=Sheets("Data")).Name = "Moats-Yates "
Sheets.Add(after:=Sheets("Data")).Name = "QREP"
Sheets.Add(after:=Sheets("Data")).Name = "Sales Engineering"
Sheets.Add(after:=Sheets("Data")).Name = "Seltec Sales"
Sheets.Add(after:=Sheets("Data")).Name = "SennTec-MacInnis"
Sheets.Add(after:=Sheets("Data")).Name = "Sigma Components "
Sheets.Add(after:=Sheets("Data")).Name = "Taylor Marketing"
Sheets.Add(after:=Sheets("Data")).Name = "Tech-Tron"
Sheets.Add(after:=Sheets("Data")).Name = "Westech Assoc"
Sheets.Add(after:=Sheets("Data")).Name = "Mexico"
Sheets.Add(after:=Sheets("Data")).Name = "International Sales"
Sheets.Add(after:=Sheets("Data")).Name = "House East"
Sheets.Add(after:=Sheets("Data")).Name = "House West"




'Copy the header row to each worksheet'

         WS_Count = ActiveWorkbook.Worksheets.Count

         For I = 2 To WS_Count
            Worksheets(I).Select
            Set ws2 = ActiveSheet
            ws.Range("1:1").Copy ws2.Range("1:1")
       
         Next I



'go through each line of data worksheet and copy into new worksheet based on name in column 19'
For x = 2 To irow

Set ws2 = Worksheets(ws.Cells(x, 19).Value)
irow2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1


ws.Range(x & ":" & x).Copy
ws2.Range(irow2 & ":" & irow2).PasteSpecial xlPasteValues

Next x

'moves worksheet into new workbook and saves file'
Call Save_worksheet_As

End Sub

Sub Save_worksheet_As()
 
    Dim FName           As String
    Dim FPath           As String
    Dim NewBook         As Workbook
 
    Set ws = Sheets("Data")


 
         WS_Count = ActiveWorkbook.Worksheets.Count

         Do While WS_Count > 1
            Worksheets(2).Select
            Set ws2 = ActiveSheet
            If ActiveSheet.Name <> "Data" Then
            irow2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row
                       ws2.Move
                       FPath = "H:\POS Data\"
                     
                       Select Case ActiveSheet.Name
                       Case Is = "Glen White Assoc."
                            FName = "POS Analysis - " & Format(Date, "yyyy-mm-dd") & " - Glen White Assoc"
                       Case Is = "English Tech. Sales"
                            FName = "POS Analysis - " & Format(Date, "yyyy-mm-dd") & " - English Tech Sales"
                       Case Else
                            FName = "POS Analysis - " & Format(Date, "yyyy-mm-dd") & " - " & ActiveSheet.Name
                       End Select
                   
                     
                            ActiveWorkbook.Close savechanges:=True, Filename:=FPath & FName
               
            End If
         WS_Count = ActiveWorkbook.Worksheets.Count
           
        Loop
 
 
End Sub

 

[NdNoviceHlp]

I'm not quite following what U want transferred to the new sheets/wbs? It seems like you're transferring all rows of data to every sheet?

'go through each line of data worksheet and copy into new worksheet based on name in column 19'
For x = 2 To irow
Set ws2 = Worksheets(ws.Cells(x, 19).Value)
irow2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
ws.Range(x & ":" & x).Copy
ws2.Range(irow2 & ":" & irow2).PasteSpecial xlPasteValues
Next x

Dave

 

[depcdivr]

Dave,

I am using X as the variable to step through the rows of the spreadsheet.
This for/next loop will
set the target worksheet name to be the name in cell (row X, col 19)
then count the rows in the worksheet (irow2)
then copy the row X (range (x:x) from the original worksheet and
paste it into target sheet in row (irow2) with Range(irow2:irow2)
then repeat with the next row of the data worksheet.

For x = 2 To irow
Set ws2 = Worksheets(ws.Cells(x, 19).Value)
irow2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
ws.Range(x & ":" & x).Copy
ws2.Range(irow2 & ":" & irow2).PasteSpecial xlPasteValues
Next x

 

[depcdivr]

Dave,

I am using X as the variable to step through the rows of the spreadsheet.
This for/next loop will
set the target worksheet name to be the name in cell (row X, col 19)
then count the rows in the worksheet (irow2)
then copy the row X (range (x:x) from the original worksheet and
paste it into target sheet in row (irow2) with Range(irow2:irow2)
then repeat with the next row of the data worksheet.

For x = 2 To irow
Set ws2 = Worksheets(ws.Cells(x, 19).Value)
irow2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
ws.Range(x & ":" & x).Copy
ws2.Range(irow2 & ":" & irow2).PasteSpecial xlPasteValues
Next x

Would it run faster if I only copied cells 1-27 instead of the entire row?

 

[NdNoviceHlp]

So you are transferring all rows (1 by 1) from the Data sheet to the new sheet (as named by column 19)? Copy and pasting takes forever but this is fixable. Dave

 

[depcdivr]

What if I were to do this instead?

Loop through the 27 columns of data and set the cells equal to each other?

For y = 1 To 27
    ws2.Cells(irow2, y) = ws.Cells(x, y).Value
Next y

If this would be faster then will that transfer a formula or just the cell value. I do not want the formula but just the value.

 

[depcdivr]

That made all the difference. It cut the run time down from 4.5hrs to 2.5 minutes. That is something I can work with. Thanks for talking it through with me. Sometimes you just need a sounding board to find the proper solution.

 

[NdNoviceHlp]

Thanks for posting your outcome. Here's my go at it. It transfers all your data to each new sheet/file. Maybe it will help. Dave

Sub Parse_data_by_rep()
Dim ObjWorkSheet As Worksheet, FPath As String, FName As String
Dim Irow As Integer, Hrng As Range, Drng As Range, Wb2 As Workbook
Dim ws As Worksheet, Lrow19 As Integer, Cnt As Integer, LastCol As Integer
'sets original spreadsheet with data being copied and counts col 19 rows
Set ws = ThisWorkbook.Sheets("Data")
Lrow19 = ws.Cells(Rows.Count, 19).End(xlUp).Row

On Error GoTo ErFix
Application.ScreenUpdating = False

For Cnt = 2 To Lrow19
With ws
'set ranges to transfer
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Irow = .Cells(Rows.Count, 2).End(xlUp).Row
Set Hrng = .Range(.Cells(1, "A"), .Cells(1, LastCol))
Set Drng = .Range(.Cells(2, "A"), .Cells(Irow, LastCol))
End With

'create new wb
Set Wb2 = Workbooks.Add
Set ObjWorkSheet = Wb2.Worksheets("Sheet1")
'Transfer headers
ObjWorkSheet.Range("A1").Resize(Hrng.Rows.Count, _
                       Hrng.Columns.Count).Cells.Value = Hrng.Cells.Value
'transfer data
ObjWorkSheet.Range("A2").Resize(Drng.Rows.Count, _
                       Drng.Columns.Count).Cells.Value = Drng.Cells.Value
'rename sheet to col 19 value
With ObjWorkSheet
.Name = CStr(ws.Cells(Cnt, 19).Value)
End With

'save wb
FPath = "H:\POS Data\"
Select Case CStr(ws.Cells(Cnt, 19).Value)
Case Is = "Glen White Assoc."
    FName = "POS Analysis - " & Format(Date, "yyyy-mm-dd") & " - Glen White Assoc"
Case Is = "English Tech. Sales"
    FName = "POS Analysis - " & Format(Date, "yyyy-mm-dd") & " - English Tech Sales"
Case Else
    FName = "POS Analysis - " & Format(Date, "yyyy-mm-dd") & " - " & CStr(ws.Cells(Cnt, 19).Value)
End Select
With Wb2
.SaveAs Filename:=FPath & FName
.Close
End With

Next Cnt

ErFix:
If Err.Number <> 0 Then
MsgBox "Error"
End If
Application.ScreenUpdating = True
End Sub