I have a Macro that loads a flat file into the current sheet. It searches a subfolder for a .dat file of the same name as the active sheet and loads in the data. I want to transition this to a vbs script that will loop through all of the sheets in the workbook and import all the data. I cannot use a macro because when the workbook is open and I try to do this, excel runs out of memory. Below is the macro:
Sub LoadData()
Dim xStrPath As String
Dim theSheet As Worksheet
Dim xFile As String
Dim xCount As Long
Dim oneCell As Range
answer = MsgBox("Are you sure you want to reload data? This will remove all existing data.", vbYesNo + vbQuestion, "Warning!")
If answer = vbYes Then
Set theSheet = Application.ActiveWorkbook.ActiveSheet
theSheet.Rows(5 & ":" & theSheet.Rows.Count).Delete
xStrPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
xFile = xStrPath & "\Old_Data\" & theSheet.Name & ".dat"
With theSheet.QueryTables.Add(Connection:="TEXT;" _
& xStrPath & "\Old_Data\" & theSheet.Name & ".dat", Destination:=theSheet.Range("A5"))
.Name = "a" & xCount
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlMSDOS
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = ","
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
For Each oneColumn In theSheet.UsedRange.Columns
With oneColumn
.ColumnWidth = 40
End With
Next oneColumn
Else
'do nothing
End If
End Sub
And below is the VBScript I tried to run:
Dim xStrPath
Dim theSheet
Dim xFile
Dim xCount
Dim oneCell
Dim theFile
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
Set xStrPath = WshShell.CurrentDirectory
Set theFile = GetObject(xStrPath & "\Base_Tables_Template.xlsm")
For Each theSheet In theFile
'Set theSheet = Application.ActiveWorkbook.ActiveSheet
theSheet.Rows(5 & ":" & theSheet.Rows.Count).Delete
xFile = xStrPath & "\Old_Data\" & theSheet.Name & ".dat"
With theSheet.QueryTables.Add(Connection:="TEXT;" _ & xStrPath & "\Old_Data\" & theSheet.Name & ".dat", Destination:=theSheet.Range("A5"))
.Name = "a" & xCount
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlMSDOS
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = ","
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
For Each oneColumn In theSheet.UsedRange.Columns
With oneColumn
.ColumnWidth = 40
End With
Next oneColumn
Next theSheet
The VBScript is giving me an expected ')' error on line 18 char 49:
This line is
With theSheet.QueryTables.Add(Connection:="TEXT;" _ & xStrPath & "\Old_Data\" & theSheet.Name & ".dat", Destination:=theSheet.Range("A5"))
This should be behaving the same as the macro. Why would the code expect a parenthesis when the macro executes just fine?
Related
there I have an excel VBA code that retrieves its records from an external file by month and set it according to the column heading.
However, i have an error in of application-defined or object-defined error in of the line .Range("A6").Resize(n, 23) = b
does anyone know why
code:
Sub zz()
Dim arr, c, b(), n&
Application.ScreenUpdating = False
Worksheets("Sheet2").Range("A6").AutoFilter
Workbooks.Open "C:\Users\sophia.tan\Desktop\MasterPlanData.xlsx", 0, 1
arr = Sheets("Excel").UsedRange
ActiveWorkbook.Close 0
c = Array(0, 2, 13, 14, 7, 8, 11, 1, 9, 10, 16, 17, 20, 22, 15, 30, 27, 28, 29, 3, 4, 30)
d = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23)
ReDim b(1 To UBound(arr), 1 To 23)
For i = 2 To UBound(arr)
If arr(i, 12) >= DateSerial(Year:=2017, Month:=11, Day:=1) And arr(i, 12) <= DateSerial(Year:=2017, Month:=11, Day:=31) Then
n = n + 1
For j = 1 To UBound(c)
b(n, d(j)) = arr(i, c(j))
Next
End If
Next
With Worksheets("Sheet2")
.Range("A6:T" & Rows.Count).CurrentRegion.AutoFilter field:=1, Criteria1:="<>OFM"
.Range("A6:T" & Rows.Count).CurrentRegion.SpecialCells(xlCellTypeVisible).AutoFilter field:=13, Criteria1:="<>Collar & Cuff"
.Range("A6:T" & Rows.Count).CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.Range("A6").Resize(n, 23) = b
.Range("A6").CurrentRegion.Sort key1:=Range("G6"), order1:=xlAscending, Header:=xlYes
.Range("A6").Select
End With
Application.ScreenUpdating = 1
End Sub
Your determination on n is subjective to the If statement. However, any unfilled values in the 'rows' of b will be vbnullstrings and will produce truly blank cells.
.Range("A6").Resize(ubound(b, 1), ubound(b, 2)) = b
Alternately,
For i = 2 To UBound(arr)
If arr(i, 12) >= DateSerial(Year:=2017, Month:=11, Day:=1) And arr(i, 12) <= DateSerial(Year:=2017, Month:=11, Day:=31) Then
n = n + 1
For j = 1 To UBound(c)
b(n, d(j)) = arr(i, c(j))
Next
End If
Next
b = application.transpose(b)
redim preserve b(lbound(b, 1) to ubound(b, 1), lbound(b, 2) to n)
b = application.transpose(b)
.Range("A6").Resize(n, 23) = b
You can only adjust the last rank of an array with ReDim when using the preserve parameter.
Try
.Range("A6").Resize(n, 23).Value = b
I'm working on a lot of pcb projects and we have an excel file that we have to enter a lot of values by hand (A drill table actually). I've some issues now...
Macro Not Saving
When I create the macro that imports the text, I can save it but when I open the excel file again the macro is gone.
Here is the code that I'm using to import a file:
Option Explicit
Sub ImportTextFile()
Dim fName As String
fName = Application.GetOpenFilename("Text Files, *.tap; *.drl")
If fName = "False" Then Exit Sub
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fName, _
Destination:=Range("$A$1"))
.Name = "sample"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "" & Chr(10) & ""
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
Sorting Values
Once I have my report imported, it looks like this:
;HEADER: 271-138-131-011
;CODE : ASCII
;FILE : ncdrill-1-10.drl for ... layers TOP and BOTTOM
;DESIGN: 131-011.brd
;T01 Holesize 1. = 20.000000 Tolerance = +2.000000/-2.000000 PLATED MILS Quantity = 360
;T02 Holesize 2. = 24.000000 Tolerance = +2.000000/-2.000000 PLATED MILS Quantity = 712
;T03 Holesize 3. = 126.000000 Tolerance = +3.940000/-3.940000 PLATED MILS Quantity = 10
;T04 Holesize 4. = 79.000000 Tolerance = +3.000000/-3.000000 NON_PLATED MILS Quantity = 1
;T05 Holesize 5. = 118.000000 Tolerance = +0.000000/-0.000000 NON_PLATED MILS Quantity = 3
%
G90
T01
X-0017100Y0160000
X-0017000Y0180000
Y0200000
Y0220000...
I actually need to take out the size of the hole and the quantity. I used in a row this function to take the size out =IF(A18="";"";RIGHT((LEFT(A18;26));7)).
For the quantity I don't know how to do it.
Once I have my hole's size and the quantity, I would like to report them on a table.
What function or macro should I writte please ?
Thank you for your help.
I'm trying to load a CSV or TSV into Excel, and for small files it works great; small files being < 5kb. The problem is that when I attempt to load larger files into Excel the process can take a long time. The files that I need the app to load can contain anywhere from 5 - 100 columns with anywhere from 5 to 20,000 rows.
I have tried using the BackgroundWorker, Threadpools, Parallel.For, Parallel.ForEach, but they all seem to have the same performance for this task.
The app itself is designed to take a list of headers from a separate text file, then load it into Excel, apply formatting, then loads the actual CSV/TSV file into Excel.
Here's what I have so far, this sub gets kicked off by the background worker:
Private Sub LoadTextFile(ByVal xlApp As Excel.Application, ByVal xlWb As Excel.Workbook, ByVal xlWs As Excel.Worksheet, ByVal xlRange As Excel.Range)
Dim SheetName As String = "Sheet1"
If xlWs Is Nothing Then
xlWs = DirectCast(xlWb.Sheets.Add(After:=xlWb.Sheets(xlWb.Sheets.Count), Count:=1, Type:=Excel.XlSheetType.xlWorksheet), Excel.Worksheet)
End If
'Read lines and store in a string array
Dim lines() As String = File.ReadAllLines(FileToLoad)
'Parse and write lines to Excel
For i As Integer = 0 To lines.Length - 1
'Set new row range
xlRange = xlWs.Range(startCol + (i + 2).ToString + ":" + endCol + (i + 2).ToString)
'Parse the line to load
Dim lineDetail() As String = lines(i).Split(fileDelimiter)
'Load into Excel
xlRange.Value = lineDetail
Next
End Sub
Here are some performance times:
89 Columns - 2,000 rows: Average Load Time = 7 sec.
89 Columns - 4,000 rows: Average Load Time = 12 sec.
91 Columns - 10,000 rows: Average Load Time = 28 sec.
91 Columns - 24,000 rows: Average Load Time = 70 sec.
107Columns - 8,732 rows: Average Load Time = 17 sec.
I keep thinking, "How does Excel load these files almost instantly?!?" Anyways, I will be super grateful to anyone that can help me optimize this so getting the data into Excel doesn't take so long. Thank you in advance.
This is what I came up with and I think it works very well. Thanks to TnTinMn for pointing me in the right direction :)
Dim xlApp As New Excel.Application
Dim xlWb As Excel.Workbook
Dim xlWs As Excel.Worksheet
Dim xlRange As Excel.Range
'Start Excel and Create Application Object
xlApp = CreateObject("Excel.Application")
'Set invisible until all loading is completed
xlApp.Visible = False
'Get/Set references of active workbook/sheet
xlWb = xlApp.Workbooks.Add
xlWb = xlApp.ActiveWorkbook
xlWs = xlWb.ActiveSheet
xlRange = xlWs.Range("$A$1")
'Used to specify the data type for each column. 2 = Text
Dim array = New Object() {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 _
, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2}
'TextFilePlatform ANSI: 1252
With xlWs.QueryTables.Add(Connection:="TEXT;" + cfg.filePath, Destination:=xlRange)
.Name = "sec"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = Excel.XlCellInsertionMode.xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = Excel.XlTextParsingType.xlDelimited
.TextFileTextQualifier = Excel.XlTextQualifier.xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = cfg.fileTSV
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = cfg.fileCSV
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = array
.TextFileTrailingMinusNumbers = True
.Refresh(BackgroundQuery:=False)
End With
'Add headers do formatting here
'<Additional Worksheet formats here>
xlApp.Visible = True
I have a macro that uses the get external data option to import a text file. Is there a way that I can prompt the user to select a file in this code or should I take a different approach? I like this approach because I can exclude some columns during the import, but I am open to other options.
With Sheets(1).QueryTables.Add(Connection:= _
"TEXT;C:\Program Files\SubDirectory\ThisIsMyFile.txt" _
, Destination:=Range("$A$1"))
.Name = "ThisIsMyFile"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(9, 9, 9, 2, 9, 2, 9, 9, 9, 2, 9, 9, 9, 2, 2, 9, 2, 9, 2, 9, 2, _
9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 9, 9, 2, 9, 2, 9, 2, 9, 2 _
, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 9, 9, 9, 9, 2, 9, 9, 9, 2, 9, 2, 9, 9, 9, _
2, 9, 9, 2, 2, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Thanks in advance!
Thanks for the help. I got this code to work:
Dim FileFilter As String
Dim Filename As String
Dim SrcWkb As Workbook
MsgBox "Select file"
FileFilter = "Text Files (*.txt), *.txt"
Filename = Application.GetOpenFilename(FileFilter, 1)
If Filename = "False" Then Exit Sub
With Sheets(1).QueryTables.Add(Connection:= _
"TEXT;" & Filename, Destination:=Range("$A$1"))
.Name = Filename
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(9, 9, 9, 2, 9, 2, 9, 9, 9, 2, 9, 9, 9, 2, 2, 9, 2, 9, 2, 9, 2, _
9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 9, 9, 2, 9, 2, 9, 2, 9, 2 _
, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 9, 9, 9, 9, 2, 9, 9, 9, 2, 9, 2, 9, 9, 9, _
2, 9, 9, 2, 2, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
Something like this should work:
Sub FileName()
fileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If fileToOpen <> False Then QueryTable fileToOpen
End Sub
Sub QueryTable(file As String)
With Sheets(1).QueryTables.Add(Connection:= _
"TEXT;" & file, Destination:=Range("$A$1"))
.Name = "ThisIsMyFile"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(9, 9, 9, 2, 9, 2, 9, 9, 9, 2, 9, 9, 9, 2, 2, 9, 2, 9, 2, 9, 2, _
9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 9, 9, 2, 9, 2, 9, 2, 9, 2 _
, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 2, 9, 9, 9, 9, 9, 2, 9, 9, 9, 2, 9, 2, 9, 9, 9, _
2, 9, 9, 2, 2, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
i have a code that has a command button which retrieves its records from an external file.
every time the command button is clicked it will delete all the records and paste again. however it allows the user input for records with "OFM","KH" and "Collar & Cuff" hence it would not delete these rows.
But, my autofilter code is not working properly as it still deletes the rows with "OFM" and "KH""
Rows.Count).CurrentRegion.SpecialCells(xlCellTypeVisible).AutoFilter
field:=1, Criteria1:="<>OFM", Operator:=xlOr, Criteria2:="<>KH"
the code:
Sub July()
Dim arr, c, b(), n&
Application.ScreenUpdating = False
Worksheets("July 2018").Range("A4").AutoFilter
Workbooks.Open "C:\Users\sophia.tan\Desktop\MasterPlanData.xlsx", 0, 1
arr = Sheets("Excel").UsedRange
ActiveWorkbook.Close 0
c = Array(0, 2, 13, 14, 7, 8, 11, 1, 9, 10, 16, 17, 20, 22, 15, 30, 27, 28,
29, 3, 4, 39)
d = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 15, 16, 17, 18, 19,
20, 21, 23)
ReDim b(1 To UBound(arr), 1 To 23)
For i = 2 To UBound(arr)
If arr(i, 13) >= DateSerial(Year:=2018, Month:=7, Day:=1) And arr(i, 12) <=
DateSerial(Year:=2018, Month:=7, Day:=31) Then
n = n + 1
For j = 1 To UBound(c)
b(n, d(j)) = arr(i, c(j))
Next
End If
Next
With Worksheets("July 2018")
.Range("A4:W" &
Rows.Count).CurrentRegion.SpecialCells(xlCellTypeVisible).AutoFilter
field:=13, Criteria1:="<>Collar & Cuff"
.Range("A4:W" &
Rows.Count).CurrentRegion.SpecialCells(xlCellTypeVisible).AutoFilter
field:=1, Criteria1:="<>OFM", Operator:=xlOr, Criteria2:="<>KH"
.Range("A4:W" & Rows.Count).CurrentRegion.Offset(1,
0).SpecialCells(xlCellTypeVisible).ClearContents
.Range("A4:W" & Rows.Count).Resize(UBound(b, 1), UBound(b, 2)) = b
.AutoFilter.ShowAllData
.Range("A4").CurrentRegion.Sort key1:=Range("G3"), order1:=xlAscending,
Header:=xlYes
.Range("A4").Select
End With
Call Fabrication
Application.ScreenUpdating = 1
End Sub
Your two-criteria-for-one-field AutoFilter logic is flawed. When something is not KH it can be OFM and when something is not OFM it can be KH. I believe you want to filter for not KH and not OFM.
tldr;
You need xlAnd, not xlOr.
'...
With Worksheets("July 2018")
If .AutoFilterMode Then .AutoFilterMode = False
With .Range("A4").CurrentRegion
.AutoFilter Field:=13, Criteria1:="<>Collar & Cuff"
.AutoFilter Field:=1, Criteria1:="<>OFM", Operator:=xlAnd, Criteria2:="<>KH" '<~~ THIS RIGHT HERE
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.SpecialCells(xlCellTypeVisible).ClearContents
End If
End With
.Cells.Sort key1:=.Columns("G"), Order1:=xlAscending, Header:=xlYes
End With
'...
.AutoFilter.ShowAllData
.Range("A4").Select
End With