Page 1 of 2 12 LastLast
Results 1 to 15 of 19
  1. #1
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post

    Post Getting error Excel is not able to complete the task/ out of memory

    Hi Experts,

    I have the below code which filters specific data from "Data" Sheet and paste the filtered data in other sheet. The same operation is performed 5 time. After filtering the data I need specific column to be paste on the respective sheets. Sometime the code works fine, but sometime it throws the above error msgs.

    Could you please help me out with it.

    Code:
    Sub Automatedata()
    Application.ScreenUpdating = False
    Dim WS, ws1 As Worksheet
    Dim pt As PivotTable
    Dim LastRow As Long
    'Property Listing
    Set WS = ActiveWorkbook.Worksheets("PL Listing")
    Set ws1 = ActiveWorkbook.Worksheets("Data")
    ws1.Activate
    LastRow = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
    Selection.AutoFilter
        Range("A1").Select
        ActiveSheet.Range("$A$1:$X$1" & LastRow).AutoFilter Field:=1, Criteria1:="PL"
    Dim SearchCols(23) As String
    SearchCols(0) = "POLICY"
    SearchCols(1) = "Policy Year"
    SearchCols(2) = "INC.DTE"
    SearchCols(3) = "INSURER REF"
    SearchCols(4) = "CLIENT"
    SearchCols(5) = "CLAIMANT"
    SearchCols(6) = "Cause"
    SearchCols(7) = "TYPE/CIRCUMSTANCES"
    SearchCols(8) = "NATURE OF INJURY"
    SearchCols(9) = "Outstanding"
    SearchCols(10) = "PAID"
    SearchCols(11) = "TOTAL"
    'SearchCols(12) = "Incurred"
    'SearchCols(13) = "Status"
    SearchCols(12) = "CLAIM / INCIDENT"
    'SearchCols(15) = "Comment"
    'continue with all the column names
    Dim i As Integer
    'Find "Entity" in Row 1
    ActiveWorkbook.Worksheets("PL Listing").Activate
    Rows("5").EntireRow.Delete
    With Sheets("Data").Rows(1)
        For i = LBound(SearchCols) To UBound(SearchCols)
            Set t = .Find(SearchCols(i), LookAt:=xlPart)
            'If found, copy the column to Sheet 2, Column A
           'If not found, present a message
          
            If Not t Is Nothing Then
                If Sheets("PL Listing").Range("B5").Value = "" Then
                    pasteCol = 2
                Else
                    pasteCol = Sheets("PL Listing").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If
               
                .Columns(t.Column).EntireColumn.Copy _
                Destination:=Sheets("PL Listing").Cells(5, pasteCol)
            Else
                MsgBox SearchCols(i) & " Not Found"
            End If
        Next
    End With
    ActiveWorkbook.Worksheets("PL Listing").Activate
    Rows("5").EntireRow.Delete
    Worksheets("PL Listing").AutoFilterMode = False
    
    ActiveWorkbook.Worksheets("Data").Activate
    Selection.AutoFilter
    'Worksheets("Data").AutoFilterMode = False
    Selection.AutoFilter
        Range("A1").Select
        LastRow = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
        ActiveSheet.Range("$A$1:$X$1" & LastRow).AutoFilter Field:=1, Criteria1:="EL"
    Dim SearchCols1(13) As String
    SearchCols1(0) = "POLICY"
    SearchCols1(1) = "Policy Year"
    SearchCols1(2) = "INC.DTE"
    SearchCols1(3) = "INSURER REF"
    SearchCols1(4) = "CLIENT"
    SearchCols1(5) = "CLAIMANT"
    SearchCols1(6) = "Cause"
    SearchCols1(7) = "TYPE/CIRCUMSTANCES"
    SearchCols1(8) = "NATURE OF INJURY"
    SearchCols1(9) = "Outstanding"
    SearchCols1(10) = "PAID"
    SearchCols1(11) = "TOTAL"
    'SearchCols(12) = "Incurred"
    'SearchCols(13) = "Status"
    SearchCols1(12) = "CLAIM / INCIDENT"
    'SearchCols(15) = "Comment"
    ActiveWorkbook.Worksheets("EL Listing").Activate
    Rows("5:" & Rows.Count).ClearContents
    'continue with all the column names
    Dim j As Integer
    'Find "Entity" in Row 1
    With Sheets("Data").Rows(1)
        For j = LBound(SearchCols1) To UBound(SearchCols1)
            Set u = .Find(SearchCols1(j), LookAt:=xlPart)
            'If found, copy the column to Sheet 2, Column A
           'If not found, present a message
          
            If Not u Is Nothing Then
                If Sheets("EL Listing").Range("B5").Value = "" Then
                    pasteCol = 2
                Else
                    pasteCol = Sheets("EL Listing").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If
               
                .Columns(u.Column).EntireColumn.Copy _
                Destination:=Sheets("EL Listing").Cells(5, pasteCol)
            Else
                MsgBox SearchCols1(j) & " Not Found"
            End If
        Next
    End With
    Worksheets("EL Listing").AutoFilterMode = False
    Rows("5").EntireRow.Delete
    ActiveWorkbook.Worksheets("Data").Activate
    Selection.AutoFilter
        Range("A1").Select
        ActiveSheet.Range("$A$1:$X$1" & LastRow).AutoFilter Field:=1, Criteria1:="PDBI"
    Dim SearchCols3(10) As String
    SearchCols3(0) = "POLICY"
    SearchCols3(1) = "Policy Year"
    SearchCols3(2) = "INC.DTE"
    'SearchCols(3) = "INSURER REF"
    SearchCols3(3) = "CLIENT"
    'SearchCols(5) = "CLAIMANT"
    SearchCols3(4) = "Cause"
    SearchCols3(5) = "TYPE/CIRCUMSTANCES"
    'SearchCols(8) = "NATURE OF INJURY"
    SearchCols3(6) = "Outstanding"
    SearchCols3(7) = "PAID"
    SearchCols3(8) = "TOTAL"
    'SearchCols(12) = "Incurred"
    SearchCols3(9) = "Status"
    SearchCols3(10) = "COMMENTARY"
    'SearchCols(15) = "Comment"
    ActiveWorkbook.Worksheets("PDBI Listing").Activate
    Rows("5:" & Rows.Count).ClearContents
    'continue with all the column names
    Dim k As Integer
    'Find "Entity" in Row 1
    With Sheets("Data").Rows(1)
        For k = LBound(SearchCols3) To UBound(SearchCols3)
            Set v = .Find(SearchCols3(k), LookAt:=xlPart)
            'If found, copy the column to Sheet 2, Column A
           'If not found, present a message
          
            If Not v Is Nothing Then
                If Sheets("PDBI Listing").Range("B5").Value = "" Then
                    pasteCol = 2
                Else
                    pasteCol = Sheets("PDBI Listing").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If
               
                  .Columns(v.Column).EntireColumn.Copy _
                Destination:=Sheets("PDBI Listing").Cells(5, pasteCol)
            Else
                MsgBox SearchCols(k) & " Not Found"
            End If
        Next
    End With
    Worksheets("PDBI Listing").AutoFilterMode = False
    Rows("5").EntireRow.Delete
    ActiveWorkbook.Worksheets("Data").Activate
    Selection.AutoFilter
        Range("A1").Select
        ActiveSheet.Range("$A$1:$X$1" & LastRow).AutoFilter Field:=1, Criteria1:="Med Mal"
    Dim SearchCols4(14) As String
    SearchCols4(0) = "POLICY"
    SearchCols4(1) = "Policy Year"
    SearchCols4(2) = "INC.DTE"
    SearchCols4(3) = "INSURER REF"
    SearchCols4(4) = "CLIENT"
    SearchCols4(5) = "CLAIMANT"
    SearchCols4(6) = "Cause"
    SearchCols4(7) = "TYPE/CIRCUMSTANCES"
    SearchCols4(8) = "NATURE OF INJURY"
    SearchCols4(9) = "Outstanding"
    SearchCols4(10) = "PAID"
    SearchCols4(11) = "TOTAL"
    SearchCols4(12) = "Status"
    SearchCols4(13) = "CLAIM / INCIDENT"
    SearchCols4(14) = "COMMENTARY"
    'SearchCols(15) = "Comment"
    ActiveWorkbook.Worksheets("Med Mal Listing").Activate
    Rows("5:" & Rows.Count).ClearContents
    'continue with all the column names
    Dim l As Integer
    'Find "Entity" in Row 1
    With Sheets("Data").Rows(1)
        For l = LBound(SearchCols4) To UBound(SearchCols4)
            Set w = .Find(SearchCols4(l), LookAt:=xlPart)
            'If found, copy the column to Sheet 2, Column A
           'If not found, present a message
          
            If Not w Is Nothing Then
                If Sheets("Med Mal Listing").Range("B5").Value = "" Then
                    pasteCol = 2
                Else
                    pasteCol = Sheets("Med Mal Listing").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If
               
                .Columns(w.Column).EntireColumn.Copy _
                Destination:=Sheets("Med Mal Listing").Cells(5, pasteCol)
            Else
                MsgBox SearchCols4(l) & " Not Found"
            End If
        Next
    End With
    Worksheets("Med Mal Listing").AutoFilterMode = False
    Rows("5").EntireRow.Delete
    ActiveWorkbook.Worksheets("Data").Activate
    Selection.AutoFilter
        Range("A1").Select
        ActiveSheet.Range("$A$1:$X$1" & LastRow).AutoFilter Field:=1, Criteria1:="Legal Expenses"
    Dim SearchCols5(15) As String
    SearchCols5(0) = "POLICY"
    SearchCols5(1) = "Policy Year"
    SearchCols5(2) = "INC.DTE"
    SearchCols5(3) = "INSURER REF"
    SearchCols5(4) = "CLIENT"
    SearchCols5(5) = "CLAIMANT"
    SearchCols5(6) = "Cause"
    SearchCols5(7) = "TYPE/CIRCUMSTANCES"
    SearchCols5(8) = "NATURE OF INJURY"
    SearchCols5(9) = "Outstanding"
    SearchCols5(10) = "PAID"
    SearchCols5(11) = "TOTAL"
    SearchCols5(12) = "Status"
    'SearchCols(13) = "CLAIM / INCIDENT"
    SearchCols5(13) = "COMMENTARY"
    'SearchCols(15) = "Comment"
    ActiveWorkbook.Worksheets("Legal Expense Listing").Activate
    Rows("5:" & Rows.Count).ClearContents
    'continue with all the column names
    Dim m As Integer
    'Find "Entity" in Row 1
    With Sheets("Data").Rows(1)
        For m = LBound(SearchCols5) To UBound(SearchCols5)
            Set x = .Find(SearchCols5(m), LookAt:=xlPart)
      '      'If found, copy the column to Sheet 2, Column A
           'If not found, present a message
          
            If Not x Is Nothing Then
                If Sheets("Legal Expense Listing").Range("B5").Value = "" Then
                    pasteCol = 2
             Else
                    pasteCol = Sheets("Legal Expense Listing").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If
               
                .Columns(x.Column).EntireColumn.Copy _
                Destination:=Sheets("Legal Expense Listing").Cells(5, pasteCol)
            Else
                MsgBox SearchCols(m) & " Not Found"
            End If
        Next
    End With
    Worksheets("Legal Expense Listing").AutoFilterMode = False
    Rows("5").EntireRow.Delete
    Worksheets("Data").AutoFilterMode = False
    End Sub
    Regards,
    JD

  2. #2
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,826
    Thanks
    136
    Thanked 482 Times in 459 Posts
    Hi Jaggi

    I'll have a look at deciphering that.
    When I'm processing a long sequence like that, I tend to create separate routines, like

    Sub step1()
    xxx
    End Sub

    Sub step2()
    xxx
    End Sub

    ...

    Sub step5()
    xxx
    End Sub

    ..then test each step one at a time, before linking them all together.

    zeddy

  3. #3
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Hi Zeddy

    I already did that before. The codes are working fine on few occassion and throws error after 5-6 attempts.

    Regards,
    JD

  4. #4
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Hi Zeddy

    I read it somewhere about the Sleep and wait function in VBA. Is it possible with these functions to sleep the MS application and the entire memory at the time to allocate to the active Sheet or macro.

    What does the below code will do?
    "Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Sleep (2000)"

    Regards,
    JD

  5. #5
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,826
    Thanks
    136
    Thanked 482 Times in 459 Posts
    Hi Jaggi

    The Sleep function is a Windows API function. This function suspends the current process thread for some number of milliseconds. 2000 milliseconds = 2 seconds. During this wait period, you are locked out of the application and all events are deferred until the wait is complete. The BREAK key cannot be used to break out of the wait.
    This function will not help you in your reported situation.

    It may be possible to speed up your process by turning calculations to Manual at the start of your procedure, and turning the calcs back to Automatic at the end of the procedure.

    zeddy

  6. #6
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Thanks Zeddy

    I applied that as well, But still not much useful.

    Regards,
    JD

  7. #7
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,637
    Thanks
    115
    Thanked 650 Times in 592 Posts
    Jaggi,

    Try this statement:

    Erase SearchCols

    before Dim SearchCols(n) again for the subsequent section or just use ReDim instead.

    Maud

  8. #8
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post

    Post

    Hi Maud

    I am already using it. I reduce the code a lot but still sometimes facing this issue. Please have a look on the current code and let me know if I am missing out something here.
    Code:
    Sub Section1()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim LastRow1 As Long
    Dim iCol As Long
       Dim ws As Worksheet
    For Each ws In Worksheets(Array("EL Listing", "PL Listing", "Med Mal Listing", "PDBI Listing", "Legal Expense Listing"))
     ws.UsedRange.RemoveSubtotal
    Next ws
    Set ws = Nothing
    Sheets("Data").Activate
    iCol = 1
        [A1].CurrentRegion.AutoFilter iCol, "PL"
        
    Dim SearchCols(14) As String
    SearchCols(0) = "Claim Reference"
    SearchCols(1) = "Policy Year"
    SearchCols(2) = "INC.DTE"
    SearchCols(3) = "INSURER REF"
    SearchCols(4) = "CLIENT"
    SearchCols(5) = "CLAIMANT"
    SearchCols(6) = "Cause"
    SearchCols(7) = "TYPE/CIRCUMSTANCES"
    SearchCols(8) = "NATURE OF INJURY"
    SearchCols(9) = "Outstanding"
    SearchCols(10) = "PAID"
    SearchCols(11) = "TOTAL"
    SearchCols(12) = "Status"
    SearchCols(13) = "CLAIM / INCIDENT"
    SearchCols(14) = "COMMENTARY"
    
    'continue with all the column names
    Dim i As Integer
    'Find "Entity" in Row 1
    Sheets("PL Listing").Activate
    Rows("5:" & Rows.Count).ClearContents
    With Sheets("Data").Rows(1)
        For i = LBound(SearchCols) To UBound(SearchCols)
            Set t = .Find(SearchCols(i), LookAt:=xlPart)
            'If found, copy the column to Sheet 2, Column A
           'If not found, present a message
          
            If Not t Is Nothing Then
                If Sheets("PL Listing").Range("B5").Value = "" Then
                    pasteCol = 2
                Else
                    pasteCol = Sheets("PL Listing").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If
               
                .Columns(t.Column).EntireColumn.Copy _
                Destination:=Sheets("PL Listing").Cells(5, pasteCol)
            Else
                MsgBox SearchCols(i) & " Not Found"
            End If
        Next
    End With
    Sheets("PL Listing").Activate
    'Sheets("PL Listing").AutoFilterMode = False
    Rows("5").EntireRow.Delete
    LastRow1 = Range("B" & Rows.Count).End(xlUp).Row
     Range("$B$5:$P$" & LastRow1).Select
     Selection.Borders(xlEdgeTop).LineStyle = xlDot
     Selection.Borders(xlEdgeBottom).LineStyle = xlDot
     Selection.Borders(xlInsideHorizontal).LineStyle = xlDot
     LastRow1 = Empty
     i = Empty
     t = Empty
     Erase SearchCols
     Application.Calculation = xlCalculationAutomatic
     Application.ScreenUpdating = True
    End Sub
    Sub Section2()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim LastRow1 As Long
    Dim iCol As Long
    Sheets("Data").Activate
    
    
    iCol = 1
        [A1].CurrentRegion.AutoFilter iCol, "EL"
        
    Dim SearchCols(13) As String
    SearchCols(0) = "Claim Reference"
    SearchCols(1) = "Policy Year"
    SearchCols(2) = "INC.DTE"
    SearchCols(3) = "INSURER REF"
    SearchCols(4) = "CLIENT"
    SearchCols(5) = "CLAIMANT"
    SearchCols(6) = "Cause"
    SearchCols(7) = "TYPE/CIRCUMSTANCES"
    SearchCols(8) = "NATURE OF INJURY"
    SearchCols(9) = "Outstanding"
    SearchCols(10) = "PAID"
    SearchCols(11) = "TOTAL"
    SearchCols(12) = "Status"
    SearchCols(13) = "CLAIM / INCIDENT"
    
    
    'continue with all the column names
    Dim i As Integer
    'Find "Entity" in Row 1
    Sheets("EL Listing").Activate
    Rows("5:" & Rows.Count).ClearContents
    With Sheets("Data").Rows(1)
        For i = LBound(SearchCols) To UBound(SearchCols)
            Set t = .Find(SearchCols(i), LookAt:=xlPart)
            'If found, copy the column to Sheet 2, Column A
           'If not found, present a message
          
            If Not t Is Nothing Then
                If Sheets("EL Listing").Range("B5").Value = "" Then
                    pasteCol = 2
                Else
                    pasteCol = Sheets("EL Listing").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If
               
                .Columns(t.Column).EntireColumn.Copy _
                Destination:=Sheets("EL Listing").Cells(5, pasteCol)
            Else
                MsgBox SearchCols(i) & " Not Found"
            End If
        Next
    End With
    Sheets("EL Listing").Activate
    Rows("5").EntireRow.Delete
    LastRow1 = Range("B" & Rows.Count).End(xlUp).Row
     Range("$B$5:$P$" & LastRow1).Select
     Selection.Borders(xlEdgeTop).LineStyle = xlDot
     Selection.Borders(xlEdgeBottom).LineStyle = xlDot
     Selection.Borders(xlInsideHorizontal).LineStyle = xlDot
     LastRow1 = Empty
     Erase SearchCols
     Application.Calculation = xlCalculationAutomatic
     Application.ScreenUpdating = True
    End Sub
    Sub Section3()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim LastRow1 As Long
    Dim iCol As Long
    Sheets("Data").Activate
    
    iCol = 1
        [A1].CurrentRegion.AutoFilter iCol, "PDBI"
        
    Dim SearchCols(10) As String
    SearchCols(0) = "Claim Reference"
    SearchCols(1) = "Policy Year"
    SearchCols(2) = "INC.DTE"
    SearchCols(3) = "CLIENT"
    SearchCols(4) = "Cause"
    SearchCols(5) = "TYPE/CIRCUMSTANCES"
    SearchCols(6) = "Outstanding"
    SearchCols(7) = "PAID"
    SearchCols(8) = "TOTAL"
    SearchCols(9) = "Status"
    SearchCols(10) = "COMMENTARY"
    
    'continue with all the column names
    Dim i As Integer
    'Find "Entity" in Row 1
    Sheets("PDBI Listing").Activate
    Rows("5:" & Rows.Count).ClearContents
    With Sheets("Data").Rows(1)
        For i = LBound(SearchCols) To UBound(SearchCols)
            Set t = .Find(SearchCols(i), LookAt:=xlPart)
            'If found, copy the column to Sheet 2, Column A
           'If not found, present a message
          
            If Not t Is Nothing Then
                If Sheets("PDBI Listing").Range("B5").Value = "" Then
                    pasteCol = 2
                Else
                    pasteCol = Sheets("PDBI Listing").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If
               
                .Columns(t.Column).EntireColumn.Copy _
                Destination:=Sheets("PDBI Listing").Cells(5, pasteCol)
            Else
                MsgBox SearchCols(i) & " Not Found"
            End If
        Next
    End With
    Sheets("PDBI Listing").Activate
    Rows("5").EntireRow.Delete
    LastRow1 = Range("B" & Rows.Count).End(xlUp).Row
     Range("$B$5:$P$" & LastRow1).Select
     Selection.Borders(xlEdgeTop).LineStyle = xlDot
     Selection.Borders(xlEdgeBottom).LineStyle = xlDot
     Selection.Borders(xlInsideHorizontal).LineStyle = xlDot
     LastRow1 = Empty
     Erase SearchCols
     Application.Calculation = xlCalculationAutomatic
     Application.ScreenUpdating = True
    End Sub
    Sub Section4()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim LastRow1 As Long
    Dim iCol As Long
    Sheets("Data").Activate
    iCol = 1
        [A1].CurrentRegion.AutoFilter iCol, "Med Mal"
        
    Dim SearchCols(14) As String
    SearchCols(0) = "Claim Reference"
    SearchCols(1) = "Policy Year"
    SearchCols(2) = "INC.DTE"
    SearchCols(3) = "INSURER REF"
    SearchCols(4) = "CLIENT"
    SearchCols(5) = "CLAIMANT"
    SearchCols(6) = "Cause"
    SearchCols(7) = "TYPE/CIRCUMSTANCES"
    SearchCols(8) = "NATURE OF INJURY"
    SearchCols(9) = "Outstanding"
    SearchCols(10) = "PAID"
    SearchCols(11) = "TOTAL"
    SearchCols(12) = "Status"
    SearchCols(13) = "CLAIM / INCIDENT"
    SearchCols(14) = "COMMENTARY"
    
    'continue with all the column names
    Dim i As Integer
    'Find "Entity" in Row 1
    Sheets("Med Mal Listing").Activate
    Rows("5:" & Rows.Count).ClearContents
    With Sheets("Data").Rows(1)
        For i = LBound(SearchCols) To UBound(SearchCols)
            Set t = .Find(SearchCols(i), LookAt:=xlPart)
            'If found, copy the column to Sheet 2, Column A
           'If not found, present a message
          
            If Not t Is Nothing Then
                If Sheets("Med Mal Listing").Range("B5").Value = "" Then
                    pasteCol = 2
                Else
                    pasteCol = Sheets("Med Mal Listing").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If
               
                .Columns(t.Column).EntireColumn.Copy _
                Destination:=Sheets("Med Mal Listing").Cells(5, pasteCol)
            Else
                MsgBox SearchCols(i) & " Not Found"
            End If
        Next
    End With
    Sheets("Med Mal Listing").Activate
    Rows("5").EntireRow.Delete
    LastRow1 = Range("B" & Rows.Count).End(xlUp).Row
     Range("$B$5:$P$" & LastRow1).Select
     Selection.Borders(xlEdgeTop).LineStyle = xlDot
     Selection.Borders(xlEdgeBottom).LineStyle = xlDot
     Selection.Borders(xlInsideHorizontal).LineStyle = xlDot
     LastRow1 = Empty
     Erase SearchCols
     Application.Calculation = xlCalculationAutomatic
     Application.ScreenUpdating = True
    End Sub
    Sub Section5()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim LastRow1 As Long
    Dim iCol As Long
    Sheets("Data").Activate
    iCol = 1
        [A1].CurrentRegion.AutoFilter iCol, "Legal Expenses"
        
    Dim SearchCols(13) As String
    SearchCols(0) = "Claim Reference"
    SearchCols(1) = "Policy Year"
    SearchCols(2) = "INC.DTE"
    SearchCols(3) = "INSURER REF"
    SearchCols(4) = "CLIENT"
    SearchCols(5) = "CLAIMANT"
    SearchCols(6) = "Cause"
    SearchCols(7) = "TYPE/CIRCUMSTANCES"
    SearchCols(8) = "NATURE OF INJURY"
    SearchCols(9) = "Outstanding"
    SearchCols(10) = "PAID"
    SearchCols(11) = "TOTAL"
    SearchCols(12) = "Status"
    SearchCols(13) = "COMMENTARY"
    
    'continue with all the column names
    Dim i As Integer
    'Find "Entity" in Row 1
    Sheets("Legal Expense Listing").Activate
    Rows("5:" & Rows.Count).ClearContents
    With Sheets("Data").Rows(1)
        For i = LBound(SearchCols) To UBound(SearchCols)
            Set t = .Find(SearchCols(i), LookAt:=xlPart)
            'If found, copy the column to Sheet 2, Column A
           'If not found, present a message
          
            If Not t Is Nothing Then
                If Sheets("Legal Expense Listing").Range("B5").Value = "" Then
                    pasteCol = 2
                Else
                    pasteCol = Sheets("Legal Expense Listing").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If
               
                .Columns(t.Column).EntireColumn.Copy _
                Destination:=Sheets("Legal Expense Listing").Cells(5, pasteCol)
            Else
                MsgBox SearchCols(i) & " Not Found"
            End If
        Next
    End With
    Sheets("Legal Expense Listing").Activate
    Rows("5").EntireRow.Delete
    LastRow1 = Range("B" & Rows.Count).End(xlUp).Row
     Range("$B$5:$P$" & LastRow1).Select
     Selection.Borders(xlEdgeTop).LineStyle = xlDot
     Selection.Borders(xlEdgeBottom).LineStyle = xlDot
     Selection.Borders(xlInsideHorizontal).LineStyle = xlDot
     Erase SearchCols
     Sheets("Data").AutoFilterMode = False
     Application.Calculation = xlCalculationAutomatic
     Application.ScreenUpdating = True
    End Sub
    
    Sub Formating()
       Application.ScreenUpdating = False
       Application.Calculation = xlCalculationManual
       ActiveWorkbook.RefreshAll
        Dim ws As Worksheet
    For Each ws In Worksheets(Array("EL Listing", "PL Listing", "Med Mal Listing", "Legal Expense Listing"))
     With ws.Range("B5")
             .RemoveSubtotal
             .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(10, 11, 12), _
                 Replace:=True, PageBreaks:=False, SummaryBelowData:=True
         End With
    Next ws
        Set ws = Nothing
        Sheets("PDBI Listing").Range("B5").Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(7, 8, 9), _
            Replace:=True, PageBreaks:=False, SummaryBelowData:=True
           
         Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
            
    End Sub
    
    Sub Automation()
    Call Section1
    Call Section2
    Call Section3
    Call Section4
    Call Section5
    Call Formating
    End Sub

  9. #9
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,637
    Thanks
    115
    Thanked 650 Times in 592 Posts
    Jaggi,

    I was looking at the code your original post. I'll take a look at your code above

  10. #10
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,826
    Thanks
    136
    Thanked 482 Times in 459 Posts
    Hi Jaggi

    It would be easier to work with a sample file.
    You could put dummy data in the sample file - we are not interested in any sensitive data.
    I can make some improvements in the code.

    Do you have conditional formatting in the sheets????
    Are you viewing any sheets in PageBreak mode????
    A sample file would tell us that, and there are other things we could check, which affects the performance.

    zeddy

  11. #11
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post

    Post

    Hi All

    I created a dummy file and it is attached with the mail. I ma facing major issue with 2013 version of the Excel.

    Regards,
    JD
    Attached Files Attached Files

  12. #12
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,637
    Thanks
    115
    Thanked 650 Times in 592 Posts
    Jaggi,

    I played with your code and could not find fault with it. It was a bit slow, however. I rewrote the code and took a different approach which is very fast an problem free. When you move to each sheet other than the Data sheet, it builds the sheets and groups them on the fly. You need to just enter the data on the Data sheet and flip between the others. Feel free to take this as a base code and tweak it from there.

    HTH,
    Maud

    Jag1.png
    Attached Files Attached Files

  13. #13
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Hi Maud

    Thanks for the tool, but it is not fitting in my need. I want to move specific columns from one sheet to another. If you check the sample file I uploaded there are blank columns I kept it blank because of its sensitivity.

    I checked my code and find one loop hole in it.

    ".Columns(t.Column).EntireColumn.Copy _
    Destination:=Sheets("PL Listing").Cells(5, pasteCol)"

    This line is the culprit. Current it is copying the entire column irrespective of blank cells. I don't know if I am right or not. Here it should copy the range instead of entire column. Please let me know your view on it.

    Regards,
    JD

  14. #14
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Hi Maud

    Could you please help me with the code to copy the range instead of entire column. I tried many permutation, but getting 438 error.

    Regards,
    JD

  15. #15
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,637
    Thanks
    115
    Thanked 650 Times in 592 Posts
    Jaggi,

    This sped up your code considerably. Line changes are in blue. You will need to apply them to each section.

    HTH,
    Maud

    Code:
    Sub Section1()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim LastRow1 As Long
    Dim iCol As Long
       Dim ws As Worksheet
    For Each ws In Worksheets(Array("EL Listing", "PL Listing", "Med Mal Listing", "PDBI Listing", "Legal Expense Listing"))
     ws.UsedRange.RemoveSubtotal
    Next ws
    Set ws = Nothing
    Sheets("Data").Activate
    lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    iCol = 1
        [A1].CurrentRegion.AutoFilter iCol, "PL"
        
    Dim SearchCols(14) As String
    SearchCols(0) = "Claim Reference"
    SearchCols(1) = "Policy Year"
    SearchCols(2) = "INC.DTE"
    SearchCols(3) = "INSURER REF"
    SearchCols(4) = "CLIENT"
    SearchCols(5) = "CLAIMANT"
    SearchCols(6) = "Cause"
    SearchCols(7) = "TYPE/CIRCUMSTANCES"
    SearchCols(8) = "NATURE OF INJURY"
    SearchCols(9) = "Outstanding"
    SearchCols(10) = "PAID"
    SearchCols(11) = "TOTAL"
    SearchCols(12) = "Status"
    SearchCols(13) = "CLAIM / INCIDENT"
    SearchCols(14) = "COMMENTARY"
    
    'continue with all the column names
    Dim i As Integer
    'Find "Entity" in Row 1
    Sheets("PL Listing").Activate
    Rows("5:" & Rows.Count).ClearContents
    With Sheets("Data").Rows(1)
        For i = LBound(SearchCols) To UBound(SearchCols)
            Set t = .Find(SearchCols(i), LookAt:=xlPart)
            'If found, copy the column to Sheet 2, Column A
           'If not found, present a message
          
            If Not t Is Nothing Then
                If Sheets("PL Listing").Range("B5").Value = "" Then
                    pasteCol = 2
                Else
                    pasteCol = Sheets("PL Listing").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If
                With Worksheets("Data")
                Range(.Cells(2, t.Column), .Cells(lastrow, t.Column)).SpecialCells(xlCellTypeVisible).Copy _
                    Destination:=Sheets("PL Listing").Cells(5, pasteCol)
                End With
            Else
                MsgBox SearchCols(i) & " Not Found"
            End If
        Next
    End With
    Application.CutCopyMode = False
    Sheets("PL Listing").Activate
    'Sheets("PL Listing").AutoFilterMode = False
    Rows("5").EntireRow.Delete
    LastRow1 = Range("B" & Rows.Count).End(xlUp).Row
     Range("$B$5:$P$" & LastRow1).Select
     Selection.Borders(xlEdgeTop).LineStyle = xlDot
     Selection.Borders(xlEdgeBottom).LineStyle = xlDot
     Selection.Borders(xlInsideHorizontal).LineStyle = xlDot
     LastRow1 = Empty
     i = Empty
     t = Empty
     Erase SearchCols
     Application.Calculation = xlCalculationAutomatic
     Application.ScreenUpdating = True
    End Sub

Page 1 of 2 12 LastLast

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •