It's probably something really simple, but I can't work out why it's doing this. All the csv files have the same headers and are the same number of columns. Yet some csvs throw the error, others don't.
Full code is below. I will attempt backflips of gratitude for anyone who can help me!Sub MergeWithFilter() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, DestRange As Range Dim rnum As Long, CalcMode As Long Dim rng As Range Dim FilterField As Integer, RangeAddress As String Dim ShName As Variant, RwCount As Long '************************************************************** '***Change these five lines of code before you run the macro*** '************************************************************** ' Change this to the pathfolder location of the files. MyPath = "C:UsersSteeeeeveDocumentsPimmDataOBISunzipOBIS" 'MyPath = "C:UsersSteeeeeveDocumentsPimmDataOBISunzipTest" ' Fill in the name of the sheet containing the data. ' Use ShName = "Sheet Name" to use a sheet name instead if its ' index. This example uses the index of the first sheet in ' every workbook. ShName = 1 ' Fill in the filter range: A1 is the header of the first ' column and G is the last column in the range and will ' filter on all rows on the sheet. ' You can also use a fixed range such as A1:G2500. RangeAddress = Range("E1:F" & Rows.Count).Address ' Set the field that you want to filter in the range ' "1 = column A" in this example because the filter range ' starts in column A. FilterField = 1 ' Fill in the filter value. Use the "<>" if you want to ' filter on the absence of a term. Or use wildcards such ' as "ron*" for cells that start with ron, or use ' "*ron*" if you look for cells where ron is a part of the ' cell value. 'SearchValue = "ron" '********************************************************** '********************************************************** ' Add a slash after MyPath if needed. If Right(MyPath, 1) <> "" Then MyPath = MyPath & "" End If ' If there are no Excel files in the folder, exit. FilesInPath = Dir(MyPath & "*.csv") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If ' Fill the myFiles array with the list of Excel files in the ' folder. FNum = 0 Do While FilesInPath <> "" FNum = FNum + 1 ReDim Preserve MyFiles(1 To FNum) MyFiles(FNum) = FilesInPath FilesInPath = Dir() Loop ' Change application properties. With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With ' Add a new workbook with one sheet. Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1 ' Loop through all files in the myFiles array. If FNum > 0 Then For FNum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next ' Set the filter range. With mybook.Worksheets(ShName) Set sourceRange = .Range(RangeAddress) End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing End If On Error GoTo 0 If Not sourceRange Is Nothing Then ' Find the last row in target worksheet. rnum = RDB_Last(1, BaseWks.Cells) + 1 With sourceRange.Parent Set rng = Nothing .AutoFilterMode = False ' Filter the range on the ' value in filter column. sourceRange.AdvancedFilter Action:=xlFilterInPlace, Unique:=True sourceRange.Copy BaseWks.Cells(rnum, "A") End With End If ' Close the workbook without saving. mybook.Close savechanges:=False End If ' Open the next workbook. Next FNum ' Set the column width in the new workbook. BaseWks.Columns.AutoFit MsgBox "Look at the merge results in the new workbook " & _ "after you click on OK." End If ' Restore the application properties. With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub Function RDB_Last(choice As Integer, rng As Range) Dim lrw As Long Dim lcol As Integer On Error Resume Next RDB_Last = rng.Find(What:="*", _ After:=rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function
Sub Step_1() Dim DstWkb As Workbook Dim rng As Range Dim RngEnd As Range Dim Cell As Range Dim rng2 As Range Set rng = Selection Set DstWkb = Workbooks("Active Position Checklist.xls") With Application .ScreenUpdating = False .EnableEvents = False 'Copy and paste the Procedure DstWkb.Worksheets("Sheet1").Range("A250").EntireRow.copy Destination:=Sheets("Report").Range("A65536").End(xlUp).Offset(1, 0) 'Restrain the filter to cells from A1 to the last entry in column X With DstWkb.Worksheets("APRData") Set rng = .Range("A1:X1") Set RngEnd = .Cells(Rows.Count, rng.Column).End(xlUp) Set rng = IIf(RngEnd.Row < rng.Row, rng, .Range(rng, RngEnd)) End With Stop 'Filter the data using column M rng.EntireRow.Autofilter Field:=13, Criteria1:=("0.00") 'Trap the error if there were no matches On Error Resume Next 'See whether there's data or not With DstWkb.Worksheets("APRData").Autofilter.Range On Error Resume Next Set rng2 = Range("A2:X20000").SpecialCells(xlCellTypeVisible) 'Set rng2 = Autofilter.Range.Offset(1, 0).Resize(Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible) On Error GoTo 0 End With If rng2 Is Nothing Then DstWkb.Worksheets("Report").Range("A65536").End(xlUp).Offset(1, 0) = "Congratulations! You have no Zero FTEs!" Else 'Copy and paste only the filtered data 'Set rng = IIf(RngEnd.Row < rng.Row, rng, .Range(rng, RngEnd)) rng.SpecialCells(xlCellTypeVisible).copy _ Destination:=DstWkb.Worksheets("Report").Range("A65536").End(xlUp).Offset(1, 0) End If 'Clear the error if there was one Err.Clear 'Return error control back to the system On Error GoTo 0 'Copy and paste the Solution Sheets("Sheet1").Range("A251").EntireRow.copy Destination:=Sheets("Report").Range("A65536").End(xlUp).Offset(1, 0) 'Turn off the autofilter Worksheets("APRData").AutoFilterMode = False End With End sub
Dim LR As Long, LRq As Long, FR As Long Dim BR As Long, i As Long, Val As String Dim wsPQ As Worksheet, wsNumNam As Worksheet Application.ScreenUpdating = False Set wsPQ = Sheets("Positions&Quals") Set wsNumNam = Sheets("Pos Numbers and Names") LR = wsNumNam.Range("A" & Rows.Count).End(xlUp).Row i = 1 Sheets.Add.Name = "Upload" Sheets("Upload").Activate Range("A2:D" & Rows.Count).ClearContents FR = 2 wsPQ.Range("A1:C1").AutoFilter LRq = wsPQ.Range("A" & Rows.Count).End(xlUp).Row On Error GoTo ErrorSkip: Do ErrorReturn: Val = wsNumNam.Range("B" & i).Text wsPQ.Range("A1:C1").AutoFilter field:=1, Criteria1:=Val wsPQ.Range("A2:C" & LRq).SpecialCells(xlCellTypeVisible).Copy Range("B" & FR) BR = Range("B" & Rows.Count).End(xlUp).Row Range("A" & FR, "A" & BR) = wsNumNam.Range("A" & i) FR = BR + 1 i = i + 1 Loop Until wsNumNam.Range("A" & i) = "" Exit Sub ErrorSkip: BR = Range("B" & Rows.Count).End(xlUp).Row FR = BR + 1 i = i + 1 GoTo ErrorReturn: Exit Sub End SubThis line is the one causing the problems:
I can see why - it's trying to copy a range that contains no visible cells. If anyone could suggest exactly what it is I need to do in order to 'skip' this error without just using 'Resume Next' (which just causes more problems for me further down the line!), I'd hugely appreciate it. Is there a reason my ErrorSkip: section doesn't help? I'm still learning VBA, so maybe there's just a term I haven't come across yet. I've tried to make the ErrorSkip: section simply set the Autofilter up to progress to the next 'Val' criteria and repeat the process, as if the issue with non-visible cells simply hadn't happened, but it doesn't seem to like it! I'm sure there's another way of doing this - maybe just getting the macro to select the area to be copied and, using an IF statement, telling it not to copy if there are no visible cells? I just don't know how to put that statement into the above code!
Like I said, when I watch the code function in Break Mode, the On Error Goto works fine the first time, but is totally ignored the second time. I think this is the crux of the issue.
For reference, wsPQ and wsNumNam are the two source worksheets (and 'Upload' is the worksheet where the collated information is placed). The autofilter criteria of 'Val' goes down the A column of wsNumNam one cell at a time, using the contents as the autofilter string (B & i etc.). The error occurs when the autofilter string provides no results.
Edit: I've attached an example of the problem, containing a few records in each worksheet. In this instance, the 'no cells found' error is occuring on the last entry in the custom autofilter list - however, in the original spreadsheet, which contains hundreds of records on both forms, the issue occurs much sooner (as it comes across an autofilter string with no results within the first 100 records or so).
Thanks a bunch for your time!
Sheet1 A B C 1 Item Count Stock 2 aa 123 yes 3 aa 456 no 4 aa 789 maybe 5 bb 123 no 6 bb 456 maybe 7 cc 123 no 8 cc 456 maybe 9 cc 789 yes Sheet2 A B 1 Item Stock 2 aa 123 3 bb n/a 4 cc 789
Private Sub UserForm_initialize() Dim wks As Worksheet Dim vaItems As Variant Dim I As Long, j As Long Dim vTemp As Variant Set wks = Sheets("Legal tracking") Me.UserFilter.List = wks.Range("B2", wks.Range("B65536").End(xlUp)).Value comboset.List = Array("Open", "Close") comboda.List = Array("Leavy", "McConnaughhay", "Rissman") comboresult.List = Array("n/a", "Yes", "No") combosettle.List = Array("n/a", "Yes", "No") combostatus.List = Array("Unresolved", "O/C Dismissed", "We agreed") combodepo.List = Array("", "Yes", "No") combodrdep.List = Array("", "Yes", "No") DCSCR.List = Array("n/a", "Yes", "No") combotime.List = Array("n/a", "Yes", "No") CESCR.List = Array("", "Yes", "No") End Sub Private Sub UserFilter_Change() Dim MyList() As Variant Dim X As Long Dim Y As Long Dim FoundSomething As Boolean FoundSomething = False Y = 0 For X = 2 To Sheets("legal tracking").Range("B" & Rows.Count).End(xlUp).Row If InStr(1, UCase(Sheets("legal tracking").Range("B" & X).Value), UCase(UserFilter)) > 0 Then FoundSomething = True ReDim Preserve MyList(Y) MyList(Y) = Sheets("legal tracking").Range("H" & X).Text Y = Y + 1 End If Next If FoundSomething Then frmlegal.filteredlist.List = MyList Else frmlegal.filteredlist.Clear End If End Sub Private Sub filteredlist_Click() Dim n As Long n = filteredlist.ListIndex If n > -1 Then With Sheets("legal tracking") n = n + 2 txtadj.Value = .Cells(n, 1).Value txtclaim.Value = .Cells(n, 2).Value txtlname.Value = .Cells(n, 3).Value txtfname.Value = .Cells(n, 4).Value txtdoi.Value = .Cells(n, 5).Value txtda.Value = .Cells(n, 6).Value comboda.Value = .Cells(n, 7).Value txtpfbrcvd.Value = .Cells(n, 8).Value txtpfbresp.Value = .Cells(n, 9).Value txtissues.Value = .Cells(n, 10).Value txtresponse.Value = .Cells(n, 12).Value DCSCR.Value = .Cells(n, 13).Value combotime.Value = .Cells(n, 14).Value CESCR.Value = .Cells(n, 15).Value txtmeddate.Value = .Cells(n, 16).Value combostatus.Value = .Cells(n, 17).Value txtpreconf.Value = .Cells(n, 18).Value comboresult.Value = .Cells(n, 19).Value combosettle.Value = .Cells(n, 20).Value txtpostmed.Value = .Cells(n, 21).Value combodepo.Value = .Cells(n, 22).Value txtdepo.Value = .Cells(n, 23).Value txtpredep.Value = .Cells(n, 24).Value combodrdep.Value = .Cells(n, 25).Value txtdrdepo.Value = .Cells(n, 26).Value txtpredr.Value = .Cells(n, 27).Value txtpretrial.Value = .Cells(n, 28).Value txtfinal.Value = .Cells(n, 29).Value txtprefinal.Value = .Cells(n, 30).Value txtconfops.Value = .Cells(n, 31).Value txtfhresults.Value = .Cells(n, 32).Value comboset.Value = .Cells(n, 34).Value txtnotes.Value = .Cells(n, 35).Value End With End If End SubThe second attempt, I used an offset code to have the data pull from the lisbox instead of the spreadsheet, but found that I could only have 9 columns in the listbox, which will not populate the 34 fields that I need to populate. I will post up the second part of code seperately as all of it's too long to fit into one post