none
Speed up the worksheet generation routine RRS feed

  • Question

  • Hello!

    Can you please help me to speed up this routine? The main purpose of this routine is to split one worksheet in the workbook into 4 new worksheets. By using the source sheet I loop through the so called ID column and where there is value 1, whole row copy into new worksheet, etc. After I making 4 new worksheet I save them as a new workbooks with specific names.

    However, it became pretty slow. I am still amateur at Excel VBA, so the code does not look professional. Can you please help me out?

    Thank you.

    Sub GenerateIOTypes()
        
        Dim ws, sh, sh1, sh2, sh3, sh4 As Worksheet
        Dim wrkb As Workbook
        Dim IOType As Integer
        Dim LR1, LR2, LR3, LR4 As Long
        Dim directory As String
        Dim fileName As String
        
        Application.ScreenUpdating = False
        
        directory = "C:\GenerateSetupFiles\"
        fileName = Dir(directory & "*.xl??")
        Workbooks.Open (directory & fileName)
        
        Set wrkb = ActiveWorkbook
        wrkb.Sheets.Add After:=Sheets(1), Count:=4
            
        Set sh = wrkb.Sheets("IOList")
        Set sh1 = wrkb.Sheets("Sheet1")
        
            With sh1
                .Activate
                .Name = "IOType1"
                .Range("A1").FormulaR1C1 = "IO Position"
                .Range("B1").FormulaR1C1 = "IO Address"
                .Range("C1").FormulaR1C1 = "IO Description"
                .Range("D1").FormulaR1C1 = "Master IO Description"
            End With
    
        Set sh2 = wrkb.Sheets("Sheet2")
            With sh2
                .Name = "IOType2"
                .Range("A1").FormulaR1C1 = "IO Position"
                .Range("B1").FormulaR1C1 = "IO Address"
                .Range("C1").FormulaR1C1 = "IO Description"
                .Range("D1").FormulaR1C1 = "Master IO Description"
            End With
            
        Set sh3 = wrkb.Sheets("Sheet3")
                With sh3
                .Name = "IOType3"
                .Range("A1").FormulaR1C1 = "IO Position"
                .Range("B1").FormulaR1C1 = "IO Address"
                .Range("C1").FormulaR1C1 = "IO Description"
                .Range("D1").FormulaR1C1 = "Master IO Description"
            End With
            
        Set sh4 = wrkb.Sheets("Sheet4")
            With sh4
                .Name = "IOType4"
                .Range("A1").FormulaR1C1 = "IO Position"
                .Range("B1").FormulaR1C1 = "IO Address"
                .Range("C1").FormulaR1C1 = "IO Description"
                .Range("D1").FormulaR1C1 = "Master IO Description"
            End With
            
        sh.Activate
        sh.Range("C2").Select
        
        Do Until ActiveCell.Value = ""
            IOType = ActiveCell.Value
            
            If IOType = 1 Then
            LR1 = sh1.Range("A" & sh1.Rows.Count).End(xlUp).row + 1
                With wrkb
                    ActiveCell.Offset(0, 4).Copy sh1.Range("A" & LR1)
                    ActiveCell.Offset(0, -1).Copy sh1.Range("B" & LR1)
                    ActiveCell.Offset(0, 13).Copy sh1.Range("C" & LR1)
                    ActiveCell.Offset(0, 5).Copy sh1.Range("D" & LR1)
                End With
                
            ElseIf IOType = 2 Then
            LR2 = sh2.Range("A" & sh2.Rows.Count).End(xlUp).row + 1
                With wrkb
                    ActiveCell.Offset(0, 4).Copy sh2.Range("A" & LR2)
                    ActiveCell.Offset(0, -1).Copy sh2.Range("B" & LR2)
                    ActiveCell.Offset(0, 13).Copy sh2.Range("C" & LR2)
                    ActiveCell.Offset(0, 5).Copy sh2.Range("D" & LR2)
                End With
                
            ElseIf IOType = 3 Then
            LR3 = sh3.Range("A" & sh3.Rows.Count).End(xlUp).row + 1
                With wrkb
                    ActiveCell.Offset(0, 4).Copy sh3.Range("A" & LR3)
                    ActiveCell.Offset(0, -1).Copy sh3.Range("B" & LR3)
                    ActiveCell.Offset(0, 13).Copy sh3.Range("C" & LR3)
                    ActiveCell.Offset(0, 5).Copy sh3.Range("D" & LR3)
                End With
                
            ElseIf IOType = 4 Then
            LR4 = sh4.Range("A" & sh4.Rows.Count).End(xlUp).row + 1
                With wrkb
                    ActiveCell.Offset(0, 4).Copy sh4.Range("A" & LR4)
                    ActiveCell.Offset(0, -1).Copy sh4.Range("B" & LR4)
                    ActiveCell.Offset(0, 13).Copy sh4.Range("C" & LR4)
                    ActiveCell.Offset(0, 5).Copy sh4.Range("D" & LR4)
                End With
            End If
            ActiveCell.Offset(1, 0).Select
        Loop
        
        For Each ws In wrkb.Worksheets
            With ws.Range("A1:D1")
                .Font.Bold = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
                .EntireColumn.AutoFit
                .Interior.Pattern = xlSolid
                .Interior.PatternColorIndex = xlAutomatic
                .Interior.ThemeColor = xlThemeColorDark1
                .Interior.TintAndShade = -0.249977111117893
                .Interior.PatternTintAndShade = 0
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlContinuous
                .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            End With
            
            With ws
                .Cells.EntireRow.AutoFit
            End With
            
        Next ws
        
    End Sub

    Saturday, November 28, 2015 6:08 PM

All replies

  • If I am interpreting the code correctly you have 4 IOtypes and you want to copy the relevant data for each IOtype to a worksheet with a name that reflects the IOtype. If this is correct then the process will be considerably faster if you use AutoFilter for each IOtype and then copy the visible data from each of the 4 required columns.

    To code this for you I really need a copy of the workbook with the source data.

    Guidelines to upload a workbook on OneDrive. (If you already use OneDrive and your process for saving to it is different then you can probably start at step 8 to get the link.)

    1. Zip your workbooks. Do not just save to OneDrive because the workbooks open with On-Line Excel and the limited functionality with the On-Line version causes problems.
    2. To Zip a file: In Windows Explorer Right click on the selected file and select Send to -> Compressed (zipped) folder.)
    3. Do not use 3rd party compression applications because I cannot unzip them. I do not clog up my computer with 3rd party apps when there are perfectly good apps supplied with windows.
    4. Go to this link.  https://onedrive.live.com
    5. Use the same login Id and Password that you use for this forum.
    6. Select Upload in the blue bar across the top and browse to the zipped folder to be uploaded.
    7. Select Open (or just double click). (Be patient and give it time to display the file after initially seeing the popup indicating it is done.)
    8. Right click the file on OneDrive and select Share.
    9. Do NOT fill in the form; Select "Get a Link" on the left side.
    10. Click the button "Create a Link"
    11. Click in the box where the link is created and it will highlight.
    12. Copy the link and paste into your reply on this forum.

    Following added as an after thought. Your code example has the path and file name hard coded. If you do provide me with an example workbook, would you like the user to be able to navigate to and select the required file rather than hard coding the path and file name?


    Regards, OssieMac



    • Edited by OssieMac Sunday, November 29, 2015 10:36 AM
    Sunday, November 29, 2015 1:48 AM
  • Still waiting on a reply. Are you able to provide me with a copy of your data?

    I prepared the following code from what I understand of your question but I cannot be sure that it is correct without your actual data to test but feel free to try it out. Note all of my comments throughout the code.

    If the code does not do as you want it to then I will need a copy of your data.

    Sub GenerateIOTypes()
       
        Dim i As Long
        'Following line only dimensions sh4 as Worksheet; remaining variables are variants
        'Dim ws, sh, sh1, sh2, sh3, sh4 As Worksheet  'Replaced with Array
        'Dim ws As Worksheet    'No longer used
        Dim sh As Worksheet
        'Following line using array replaces individual variables.
        Dim arrShts() As Worksheet
        Dim wrkb As Workbook
        Dim IOType As Integer
        'Following line only dimensions LR4 as Long; remaining variables are variants
        'Dim LR1, LR2, LR3, LR4 As Long
        Dim LR1 As Long, LR2 As Long, LR3 As Long, LR4 As Long  'Dimension this way or use single rows
        Dim directory As String
        Dim fileName As String
        Dim rngToCopy As Range
        Dim rngDestin As Range
        Dim lngOffset As Long
        Dim lngShts As Long
       
        lngShts = 4     'Set to the number of worksheets to be added(Number of IOTypes)
        ReDim arrShts(1 To lngShts)    'Re-Dimensions a one based array with lngShts elements
       
        Application.ScreenUpdating = False
        
        directory = "C:\GenerateSetupFiles\"
        fileName = Dir(directory & "*.xl??")
        Workbooks.Open (directory & fileName)  'Becomes the ActiveWorkbook
       
        Set wrkb = ActiveWorkbook   'Newly opened workbook is the ActiveWorkbook.
       
        'Test if any IOType sheets already exist in the workbook and if so, terminate processing
        For Each sh In wrkb.Worksheets
            If Left(sh.Name, 6) = "IOType" Then
                MsgBox "One or more IOType worksheets exist." & vbCrLf & _
                    "Delete these sheets from the workbook" & vbCrLf & _
                    "and re-start the processing." & vbCrLf & vbCrLf & _
                    "Processing terminated."
                Exit Sub
            End If
        Next sh
       
        'Add the number of new sheets required.
        'Save sheet to worksheet variable
        'Name the worksheet.
        For i = 1 To lngShts
            wrkb.Sheets.Add After:=Sheets(wrkb.Sheets.Count)    'Add worksheet
            Set arrShts(i) = ActiveSheet    'Assign new sheet to array element. (New sheet is always the ActiveSheet)
            arrShts(i).Name = "IOType" & i  'Name the worksheet
        Next i
           
        Set sh = wrkb.Sheets("IOList")
       
        For i = 1 To lngShts
            With arrShts(i)
                .Range("A1").FormulaR1C1 = "IO Position"
                .Range("B1").FormulaR1C1 = "IO Address"
                .Range("C1").FormulaR1C1 = "IO Description"
                .Range("D1").FormulaR1C1 = "Master IO Description"
            End With
        Next i
           
        'sh.Activate     'Not required but can remain if preferred
        'sh.Range("C2").Select  'Not required
       
        With sh
            .AutoFilterMode = False     'Ensure all data visible by turning off AutoFilter (if on)
           
            'Next line turns on AutoFilter for all column headers.
            .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)).AutoFilter
           
            For IOType = 1 To lngShts
                With .AutoFilter.Range  '.AutoFilter.Range is generic range for filtered data
                    .AutoFilter Field:=3, Criteria1:=IOType  'Set Autofilter on column 3 (column "C")
                   
                    'Following If test because code will error if no visible data below column headers.
                    'Count greater than 1 indicates that more than column header rows are visible.
                    If .Columns(3).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
                        Set rngToCopy = .Columns(7) _
                                        .Offset(1, 0) _
                                        .Resize(.Rows.Count - 1) _
                                        .SpecialCells(xlCellTypeVisible)
                   
                        With arrShts(IOType)    'Addresses the sheet variable in the array.
                            'Following line finds next blank cell in column "A"
                            Set rngDestin = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
                        End With
                        rngToCopy.Copy Destination:=rngDestin
                       
                        Set rngToCopy = .Columns(3) _
                                        .Offset(1, 0) _
                                        .Resize(.Rows.Count - 1) _
                                        .SpecialCells(xlCellTypeVisible)
                   
                        With arrShts(IOType)    'Addresses the sheet variable in the array.
                            'Following is one cell to right of previous destination
                            Set rngDestin = rngDestin.Offset(0, 1)
                        End With
                        rngToCopy.Copy Destination:=rngDestin
                       
                        Set rngToCopy = .Columns(16) _
                                        .Offset(1, 0) _
                                        .Resize(.Rows.Count - 1) _
                                        .SpecialCells(xlCellTypeVisible)
                   
                        With arrShts(IOType)    'Addresses the sheet variable in the array.
                            'Following is one cell to right of previous destination
                            Set rngDestin = rngDestin.Offset(0, 1)
                        End With
                        rngToCopy.Copy Destination:=rngDestin
                       
                        Set rngToCopy = .Columns(8) _
                                        .Offset(1, 0) _
                                        .Resize(.Rows.Count - 1) _
                                        .SpecialCells(xlCellTypeVisible)
                   
                        With arrShts(IOType)    'Addresses the sheet variable in the array.
                            'Following is one cell to right of previous destination
                            Set rngDestin = rngDestin.Offset(0, 1)
                        End With
                        rngToCopy.Copy Destination:=rngDestin
                       
                    End If
                End With
                '
            Next IOType
            .AutoFilterMode = False
         End With
        
        'Looping through the array of worksheets only
        'applies formatting to the added worksheets
        For i = 1 To lngShts
            With arrShts(i)
                With .Range("A1:D1")
                    .Font.Bold = True
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlBottom
                    '.EntireColumn.AutoFit  'All done together below
                    .Interior.Pattern = xlSolid
                    .Interior.PatternColorIndex = xlAutomatic
                    .Interior.ThemeColor = xlThemeColorDark1
                    .Interior.TintAndShade = -0.249977111117893
                    .Interior.PatternTintAndShade = 0
                    .Borders(xlEdgeLeft).LineStyle = xlContinuous
                    .Borders(xlEdgeTop).LineStyle = xlContinuous
                    .Borders(xlEdgeBottom).LineStyle = xlContinuous
                    .Borders(xlEdgeRight).LineStyle = xlContinuous
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                End With
               
                'Using nested With statements allows following code to be applied to
                'entire worksheet and previous code to be applied to specific range.
                .UsedRange.Columns.AutoFit        'This applies to all columns of used range on worksheet.
                .UsedRange.Rows.AutoFit           'This applies to all rows of used range on worksheet.
                '.Cells.EntireRow.AutoFit   'Use above in lieu of this line
            End With
        Next i
       
        'Clean up Object variables. (Not required for other variables)
        Set rngToCopy = Nothing
        Set rngDestin = Nothing
        Set sh = Nothing
        ReDim arrShts(1)   'Redim without preserve empties the array
        Set wrkb = Nothing
    End Sub


    Regards, OssieMac

    Monday, November 30, 2015 1:19 AM