• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA Query regarding wait and sleep function.

Jagdev Singh

Active Member
Hi Experts

I have a query about the Application.Wait and Sleep function in VBA. Is it possible to sleep all the current application in Microsoft with this and run the Active macro. I am encountering an error message while running a macro code. The error msg is “Excel can’t complete the task with current resource. Close some application”. I googled to find the remedy of this issue and find the wait and Sleep function.

Is it possible with anyone function to sleep the rest of the MS application and execute the current macro and once the code is completed, active these applications.

What exactly it does and is it good to perform this exercise.

Is it feasible to perform this action.

Regards,

JD
 
Application.Wait tells the code to pause it's running, and resume after set time. This is seen often when you work with web pages, as you want to make sure the page has loaded before continuing.

I do not think this is what you want to do. I would first ask, what step in the code is cuasing the error? Are you trying to copy/paste a large amount of data? Are you perhaps accidentally trying to shift data off the page (inserting rows/columns).
 
Hi Luke

I am trying to filter a sheet and copy the filtered data in different sheets.

Here is the code: The code is working fine sometime and sometime it throws an error "Excel is not able to complete the task - Select less data or Close some application" Error 2 "Out of memory usage".

Code:
'Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Automatedata()
Application.ScreenUpdating = False
Dim WS, ws1 As Worksheet
'Sleep (2000)
Dim LastRow As Long
Dim LastRow1 As Long
Dim LastRow2 As Long
'Property Listing

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) = "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) = "Incurred"
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
ActiveWorkbook.Worksheets("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
ActiveWorkbook.Worksheets("PL Listing").Activate
Worksheets("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
Erase SearchCols
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) = "Claim Reference"
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(12) = "Status"
SearchCols1(13) = "CLAIM / INCIDENT"
'SearchCols(14) = "COMMENTARY"
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
LastRow2 = Range("B" & Rows.Count).End(xlUp).Row
Range("$B$5:$P$" & LastRow2).Select
Selection.Borders(xlEdgeTop).LineStyle = xlDot
Selection.Borders(xlEdgeBottom).LineStyle = xlDot
Selection.Borders(xlInsideHorizontal).LineStyle = xlDot
Erase SearchCols1
Call Section2

End Sub

Sub Section2()
Dim LastRow As Long
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim lastRow3 As Long
LastRow = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
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) = "Claim Reference"
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 SearchCols3(k) & " Not Found"
        End If
    Next
End With

Worksheets("PDBI 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
Erase SearchCols3
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) = "Claim Reference"
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
LastRow2 = Range("B" & Rows.Count).End(xlUp).Row
Range("$B$5:$P$" & LastRow2).Select
Selection.Borders(xlEdgeTop).LineStyle = xlDot
Selection.Borders(xlEdgeBottom).LineStyle = xlDot
Selection.Borders(xlInsideHorizontal).LineStyle = xlDot
Erase SearchCols4

Worksheets("Data").AutoFilterMode = False
End Sub
 
Hmm. In my experience, when filtering large amounts of data, it's usually easier to use the AdvancedFilter. You can run it programmatically too. Take a look, and see if something like this might help?
http://www.contextures.com/xladvfilter01.html

Linked instructions show the manual filter, but as I said, it can be ran via VBA if needed. Look more at how it functions (headers/criteria).
 
Hi Luke

I left for the day will look into it tomorrow. My filter data range is around 270. The code runs fine on few instances nd get stuck sometimes.

Regards
JD
 
@Marc - It is already capturing the range while coping the data.

@Luke - I amended the code at great extent here is the revised version, but again I am facing the same error on few instances. Please let me know if I am doing something wrong 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 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
 
This line:
Code:
 .Columns(t.Column).EntireColumn.Copy _
            Destination:=Sheets("PL Listing").Cells(5, pasteCol)
may be your culrprit, and alludes to what Marc was saying. If this line tries to run, it's going to copy an entire column of data. There's obviously more, but for this example, say a worksheet has 10,000 rows. So, we copy all 10,000 rows. HOWEVER, we then tell it to paste into row 5. This causes a problem, as only the first 9,995 cells from our source can be copied, the the remaining 5 would "overrun" the sheet. :eek:

I'd suggest changing that line of code to be:
Code:
Intersect(.UsedRange, .Columns(t.Column).EntireColumn).Copy _
            Destination:=Sheets("EL Listing").Cells(5, pasteCol)
The Intersect says to take only the cells where the Used Range of the Sheet and the column intersect. Twofold benefit is that we're using less memory by copying fewer cells, and we also don't risk overflowing the end of the sheet we are pasting to.

PS. I didn't go through all of the code, only got up to that line. Looks like much of the code is repeated, so would need to be fixed throughout.
 
Hi Luke

I am getting an error with this code " Error: 438 - Object dosen't support this property or method".

Regards,
JD
 
Ah, I forgot you were calling t within the Column. Try this:
Code:
Intersect(.UsedRange, t.EntireColumn).Copy _
            Destination:=Sheets("EL Listing").Cells(5, pasteCol)
 

EntireColumn does not means 10 000 rows
but 1 048 576 rows since version 2007 of Excel ‼

So try without it …
 
Hi Luke

I am still getting the same error - 438 at the replaced coding line

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

Regards,
JD
 
Hi JD,

Can you share your workbook? You can remove the data, looks like the macro just needs the headers. Everything I build/test on my end seems to work, so I'm unsure how to advise further. :(
 
Thanks, I see it now. I misread the leading With statement. I thought it just referred to the sheet, but it included a row reference. Line should be:
Code:
Intersect(Worksheets("Data").UsedRange, t.EntireColumn).Copy _
            Destination:=Sheets("PL Listing").Cells(5, pasteCol)
Sorry for the confusion on my part. :eek:
 
Hi Luke

The code is now working fine, but after completing the entire pasting task throws an error - Error 91: Object Variable or with block variable not set"

Line of Error
"Intersect(Worksheets("Data").UsedRange, t.EntireColumn).Copy _
Destination:=Sheets("PL Listing").Cells(5, pasteCol)"

Regards,
JD
 

Luke, may the force be with you !

Don't you think instead of SearchCols() an advanced filter
could be an easier and faster way ? …
 
@jd
I'm confused...did the code work, or not work? Your last post was unclear. Entire macro runs on my machine with last file and change. No error messages.

@Marc
Yep, would be much faster. Admittedly, this thread started off as a simple Q&A, and then a bad line of code (and my bumbling attempt to fix it). Taking the time to look at whole picture, it would be better (faster run time) to setup a criteria range and Advanced Filter. If you want to take a crack at setting it up, I'd encourage the effort. :)
 

Well I have no much time these days for reverse engineering !

Easier with sample source and desired result workbook and
a good analyse of the need from OP …
 
Hi Luke

I mean to say the code is working fine, but after pulling necessary column from Data Sheet to PL sheet it throw the error I have attached the error screenshot with the mail.

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(15) 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
           
         
          Intersect(Worksheets("Data").UsedRange, t.EntireColumn).Copy _
            Destination:=Sheets("PL Listing").Cells(5, pasteCol)
       
        Else
            MsgBox SearchCols(i) & " Not Found"
        End If
    Next
End With
Application.CutCopyMode = 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

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
 

Attachments

  • Capture.PNG
    Capture.PNG
    18.8 KB · Views: 0
  • Capture1.PNG
    Capture1.PNG
    3.4 KB · Views: 0
Problem is with your array. You defined SearchCols as having 16 elements (0-15) in this line
Code:
Dim SearchCols(15) As String
but you never set a value for SearchCols(15). Then, when the Find gets to i = 15, it tries to find a cell with a value of "". This then causes the code to try and pull a blank cell, aka a blank column.

You should change the line of code above to define SearchCols as
Code:
Dim SearchCols(14) As String
 
Back
Top