I started VBA - programming 2 days ago and I'm having efficiency problems given my limited knowledge of VBA and EXCEL.
I'm moving data from .CSV to .xlsm files. The .CSV file i receive is structured as
SHEET;COL;ROW;VALUE.
This .CSV is then read to a multidimension array and populates an excel file withwb.Worksheets(ARRAY(i, SHEET)).Cells(R,C) = ARRAY(i, VALUE)
To my understanding, applying the array to a range of cells does not work, as there is no continuous surface to which i'm sending each individual .csv row.
What i've tried most of it can be seen below. I believe a big issue i'm having is the pass-through between VBA -> EXCEL for each .CSV row. Is there any way this can be done by bulk instead?
All types of comments about efficiency and general how-to in VBA is greatly appreciated!
Option Explicit
Private Sub imp_Data()
'----------------------------File Dialog for data input-----------------
Dim Valarr As Variant
Dim fullpath As String
Dim CSVSHEET As Integer, CSVCOL As Integer, CSVROW As Integer, CSVVALUE As Integer
fullpath = [YOUR TEST FILE.CSV]
'----------------------------Read rawdata----------------------------
Dim RawData As String
Open fullpath For Binary As #1
RawData = Space$(LOF(1))
Get #1, , RawData
Close #1
'----------------------------Split rawdata into array-------------------
Dim r As Long, Nrow As Long, Ncol As Long
Dim c As Integer
Dim lineArr As Variant, cellArr As Variant
If Len(RawData) > 0 Then
'Split each row in CSV to str array
lineArr = Split(Trim$(RawData), vbCrLf)
'Dim final array
Nrow = UBound(lineArr) + 1
Ncol = UBound(Split(lineArr(0), ";")) + 1
ReDim Valarr(1 To Nrow, 1 To Ncol)
'Split each col on delimiter ";"
For r = 1 To Nrow
If Len(lineArr(r - 1)) > 0 Then
cellArr = Split(lineArr(r - 1), ";")
For c = 1 To Ncol
Valarr(r, c) = cellArr(c - 1)
Next c
End If
Next r
Else
Debug.Print "No data read"
' do more stuff
End If
'----------------------------Read Table positions-----------------------
Dim i As Integer
For i = 1 To Ncol
If UCase(Valarr(1, i)) = "SHEET" Then
CSVSHEET = i
ElseIf UCase(Valarr(1, i)) = "COL" Then
CSVCOL = i
ElseIf UCase(Valarr(1, i)) = "ROW" Then
CSVROW = i
ElseIf UCase(Valarr(1, i)) = "VALUE" Then
CSVVALUE = i
End If
Next i
'Turn off calculation and screen update for efficiency
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'--------------------------------------------Send data to Cells----------
Dim L As Long
Dim wb As Workbook
Set wb = ThisWorkbook
L = UBound(Valarr, 1) - LBound(Valarr, 1) + 1
For i = 2 To L
If IsEmpty(Valarr(i, 1)) = 0 Then
wb.Worksheets(Valarr(i, CSVSHEET)).Cells(Valarr(i, CSVROW), Valarr(i, CSVCOL)) = Valarr(i, CSVVALUE)
End If
Next i
'Release ValArr memory
ReDim Valarr(0)
Erase Valarr
'Reapply calculation/screen update
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
From tests with 1 million rows it takes 14 seconds to read data to array and 5+ minutes to move the data to their designated cell. So the issue in the code below is (what i believe)
For i = 2 To L
If IsEmpty(Valarr(i, 1)) = 0 Then
wb.Worksheets(Valarr(i, CSVSHEET)).Cells(Valarr(i, CSVROW), Valarr(i, CSVCOL)) = Valarr(i, CSVVALUE)
End If
Next i
Related
I have some data files (.dat) that are very large (exceed the 1,048,000 rows Excel allows). I can't quite figure out what the problem is with the attempted macros (originally written for text files with "," delimiter, not .dat files with tab delimiter). The macro works, however it causes the data to be compiled into one column (ex. supposed to be 5 columns, now 1 column with all the numbers as a long text string). Is there a better way to open a very large .dat file, split it up and import it into separate worksheets while keeping the data in separate columns using the tab delimiter?
Sub ImportBigFile()
Dim N As Long
Dim Lim As Long
Dim SS() As String
Dim S As String
Dim R As Long
Dim C As Long
Dim WS As Worksheet
Dim FNum As Integer
Dim FName As String
FName = "C:\Folder 1\Folder 2\File.dat"
FNum = FreeFile
With ActiveWorkbook.Worksheets
Set WS = .Add(after:=.Item(.Count))
End With
Lim = WS.Rows.Count
Open FName For Input Access Read As #FNum
R = 0
Do Until EOF(FNum)
R = R + 1
Line Input #FNum, S
SS = Split(S, "\t", -1)
For C = LBound(SS) To UBound(SS)
WS.Cells(R, C + 1).Value = SS(C)
Next C
If R = Lim Then
With ActiveWorkbook.Worksheets
Set WS = .Add(after:=.Item(.Count))
End With
R = 0
End If
Loop
End Sub
SS = Split(S, "\t", -1)
should be
SS = Split(S, chr$(9), -1)
Assuming your tab is ascii
This fixes 2 issues, and improves performance
As mentioned, the delimiter used in Split (vbTab)
You open the file for Input but never close it
Uses an array to convert to range format, then places it on the range in one operation
Test file used contains 3,145,731 Rows and 5 Cols (122 Mb)
your code: 3.9 min (231.755 sec)
this code: 1.1 Min ( 64.966 sec)
Option Explicit
Public Sub ImportBigFile2()
Const fName = "C:\Folder 1\Folder 2\File.dat"
Dim maxR As Long, maxC As Long, wsCount As Long, arr As Variant, rng As Variant
Dim fNum As Long, fText As String, ws As Worksheet, ln As Variant, nextR As Long
Dim i As Long, r As Long, c As Long, t As Double, ubArr As Long
t = Timer: fNum = FreeFile: maxR = ThisWorkbook.Worksheets(1).Rows.Count
Open fName For Input Access Read As #fNum
fText = Input$(LOF(1), 1)
Close #fNum
arr = Split(fText, vbCrLf): ubArr = UBound(arr)
maxC = UBound(Split(arr(0), vbTab)) + 1
wsCount = ubArr \ maxR + 1: nextR = 0
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets
For i = 1 To wsCount
Set ws = .Add(After:=.Item(.Count))
ReDim rng(1 To maxR, 1 To maxC)
For r = 1 To maxR
ln = Split(arr(nextR), vbTab)
For c = 1 To UBound(ln) + 1
rng(r, c) = ln(c - 1)
Next
nextR = nextR + 1: If nextR > ubArr Then Exit For
Next
ws.Range(ws.Cells(1, 1), ws.Cells(maxR, maxC)) = rng
Next
End With
Application.ScreenUpdating = True
Debug.Print "Time: " & Format(Timer - t, "#,###.000") & " sec" 'Time: 64.966 sec
End Sub
Before (CSV file)
After
I want to randomly select 50 rows from one sheet and pasting them in a separate workbook for data sampling. I don't know how to do it because first, I'm new to VBA, I want to learn something new and second, I tried searching this on Google but no accurate answer found.
So what's on my mind is this:
I'll get first the number of rows in that worksheet. I've already
done it with this one line of code:
CountRows = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Get a random number from 1 to CountRows uniquely. The random numbers should be incremental (1,5,7,20,28,30,50 and no backward counting). Then grab that row, create a new workbook if not yet open and paste it there.
How can I achieve this process? I have no idea how to start this.
First, generate an array of 50 unique numbers between 1 and CountRows, using this routine:
' Generate a sorted array(0 to count-1) numbers between a and b inclusive
Function UniqueRandom(ByVal count As Long, ByVal a As Long, ByVal b As Long) As Long()
Dim i As Long, j As Long, x As Long
ReDim arr(b - a) As Long
Randomize
For i = 0 To b - a: arr(i) = a + i: Next
If b - a < count Then UniqueRandom = arr: Exit Function
For i = 0 To b - a 'Now we shuffle the array
j = Int(Rnd * (b - a))
x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
' After shuffling the array, we can simply take the first portion
ReDim Preserve arr(0 To count - 1)
'sorting, probably not necessary
For i = 0 To count - 1
For j = i To count - 1
If arr(j) < arr(i) Then x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
Next
UniqueRandom = arr
End Function
Now you can use the above routine to generate random, unique and sorted indexes and copy the corresponding rows. Here's an example:
Sub RandomSamples()
Const sampleCount As Long = 50
Dim lastRow As Long, i As Long, ar() As Long, rngToCopy As Range
With Sheet1
lastRow = .Cells(.Rows.count, "A").End(xlUp).row
ar = UniqueRandom(sampleCount, 1, lastRow)
Set rngToCopy = .Rows(ar(0))
For i = 1 To UBound(ar)
Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
Next
End With
With Workbooks.Add
rngToCopy.Copy .Sheets(1).Cells(1, 1)
.SaveAs ThisWorkbook.path & "\" & "samples.xlsx"
.Close False
End With
End Sub
Following code will do what you need.
Sub Demo()
Dim lng As Long
Dim tempArr() As String
Dim srcWB As Workbook, destWB As Workbook
Dim rng As Range
Dim dict As New Scripting.Dictionary
Const rowMax As Long = 100 'maximum number of rows in source sheet
Const rowMin As Long = 1 'starting row number to copy
Const rowCopy As Long = 50 'number of rows to copy
Dim intArr(1 To rowCopy) As Integer, rowArr(1 To rowCopy) As Integer
Set srcWB = ThisWorkbook
'get unique random numbers in dictionary
With dict
Do While .Count < rowCopy
lng = Rnd * (rowMax - rowMin) + rowMin
.Item(lng) = Empty
Loop
tempArr = Split(Join(.Keys, ","), ",")
End With
'convert random numbers to integers
For i = 1 To rowCopy
intArr(i) = CInt(tempArr(i - 1))
Next i
'sort random numbers
For i = 1 To rowCopy
rowArr(i) = Application.WorksheetFunction.Small(intArr, i)
If rng Is Nothing Then
Set rng = srcWB.Sheets("Sheet1").Rows(rowArr(i))
Else
Set rng = Union(rng, srcWB.Sheets("Sheet1").Rows(rowArr(i)))
End If
Next i
'copy random rows, change sheet name and destination path as required
Set destWB = Workbooks.Add
With destWB
rng.Copy destWB.Sheets("Sheet1").Range("A1")
.SaveAs Filename:="D:\Book2.xls", FileFormat:=56
End With
End Sub
Above code uses Dictionary so you have to add reference to Microsoft Scripting Runtime Type Library. In Visual Basic Editor, go to Tools->References and check "Microsoft Scripting Runtime" in the list.
Let me know if anything is not clear.
I'm not a developer but I read a bit here and there to be able to understand some of it. This might be a simple problem that I'm facing but I can't seem to figure it out. So thank you for helping me on this!
I wrote with the help of Google a short script that is supposed to turn a CSV export into a readable format. It is supposed to do a few more things but I'm already facing performance issues just with the objective of making a few entries readable.
Here's what I have so far:
Sub MagicButton_Click()
'Find the last non-empty cell in column A
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'Set Variables to work with the cell content
Dim CellContent As String
Dim CellContentArr As Variant
'Set looping variables
Dim i, j As Integer
Dim FirstRow As Integer
Dim FirstCol As Integer
Dim ActiveCol As Integer
Dim itm As Variant
FirstRow = 1
FirstCol = 2
Dim x, y As String
'Loop (1) through all rows
For i = FirstRow To LastRow
'Save cell content to string
CellContent = ActiveSheet.Cells(i, 1).Text
'Split string into array
CellContentArr = Split(CellContent, "{")
'Reset column
ActiveCol = FirstCol
'Loop (2) through the array
For Each itm In CellContentArr
'Remove quotations and other symbols
itm = Application.WorksheetFunction.Clean(itm)
itm = Replace(itm, """", "")
'This is the part that creates performance issues
'For j = 1 To Len(itm)
' x = Mid(itm, j, 1)
' If x Like "[A-Z,a-z,0-9 :.-]" Then
' y = y & x
' End If
'Next j
'itm = y
'y = ""
'Write each item in array to an individual cells within the same row
ActiveSheet.Cells(i, ActiveCol) = itm
ActiveCol = ActiveCol + 1
Next itm
Next i
End Sub
This entire script works fine when I test on ~10 rows. When using it on the entire set of 220 rows, it becomes unresponsive and eventually crashes.
In the script I have commented what causes this performance issue. I'm guessing it is because there are three loops. The third loop iterates through every char in the string to check if it is an allowed char or not and then keeps or deletes it.
What can I do to improve performance, or at least, make it so that Excel doesn't turn unresponsive?
Sidenote: It is supposed to work both on Mac & Windows. I don't know if RegEx would have a better performance to filter out the unwanted char, but I also don't know if it is possible to use that for both Mac & Windows.
The answers that have been given would be good adjustments to your code. However, there might be a better approach to this.
Firstly, reading a range into an array and manipulating the resultant array is markedly faster than reading cell by cell.
Secondly, if you are iterating each character in your array and checking for specific items with a curly bracket signalling a new column, then couldn't you just do it all in one iteration. It seems a little redundant to split and clean first.
All in all, your code could be as simple as this:
Dim lastCell As Range
Dim v As Variant
Dim r As Long
Dim c As Long
Dim i As Integer
Dim output() As String
Dim b() As Byte
'Read the values into an array
With ThisWorkbook.Worksheets("Sheet1")
Set lastCell = .Cells(.Rows.Count, "A").End(xlUp)
v = .Range(.Cells(1, "A"), lastCell).Value2
End With
ReDim output(1 To UBound(v, 1), 1 To 1)
'Loop through the array rows and characters
For r = 1 To UBound(v, 1)
c = 1
'Convert item to byte array - just personal preference, you could iterate a string
b = StrConv(v(r, 1), vbFromUnicode)
For i = 0 To UBound(b)
Select Case b(i)
Case 45, 46, 58, 65 To 90, 97 To 122, 48 To 57 '-, :, ., A-Z, a-z, 0-9
output(r, c) = output(r, c) & Chr(b(i))
Case 123 '{
'add a column and expand output array if necessary
If Len(output(r, c)) > 0 Then
c = c + 1
If c > UBound(output, 2) Then
ReDim Preserve output(1 To UBound(v, 1), 1 To c)
End If
End If
Case Else
'skip it
End Select
Next
Next
'Write item to worksheet
ThisWorkbook.Worksheets("Sheet1").Cells(1, "B") _
.Resize(UBound(output, 1), UBound(output, 2)).Value = output
Three things - you need to disable screenupdating and you need to declare variables in a better way. Do not do it like "Dim a,b,c,d,e as Integer", because only the last one is integer, the others are variant. Last but not least, do not use Integer in VBA, but this is not your problem here.
This should work faster:
Sub MagicButton_Click()
'Find the last non-empty cell in column A
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'Set Variables to work with the cell content
Dim CellContent As String
Dim CellContentArr As Variant
'Set looping variables
Dim i As Long
dim j as Long
Dim FirstRow As Long
Dim FirstCol As Long
Dim ActiveCol As Long
Dim itm As Variant
FirstRow = 1
FirstCol = 2
Dim x as string
dim y As String
call onstart
'Loop (1) through all rows
For i = FirstRow To LastRow
'Save cell content to string
CellContent = ActiveSheet.Cells(i, 1).Text
'Split string into array
CellContentArr = Split(CellContent, "{")
'Reset column
ActiveCol = FirstCol
'Loop (2) through the array
For Each itm In CellContentArr
'Remove quotations and other symbols
itm = Application.WorksheetFunction.Clean(itm)
itm = Replace(itm, """", "")
'This is the part that creates performance issues
'For j = 1 To Len(itm)
' x = Mid(itm, j, 1)
' If x Like "[A-Z,a-z,0-9 :.-]" Then
' y = y & x
' End If
'Next j
'itm = y
'y = ""
'Write each item in array to an individual cells within the same row
ActiveSheet.Cells(i, ActiveCol) = itm
ActiveCol = ActiveCol + 1
Next itm
Next i
call onend
End Sub
Public Sub OnStart()
Application.AskToUpdateLinks = False
Application.ScreenUpdating = False
Application.Calculation = xlAutomatic
Application.EnableEvents = False
Application.DisplayAlerts = False
End Sub
Public Sub OnEnd()
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.StatusBar = False
Application.AskToUpdateLinks = True
End Sub
Task List
Copy source range into an array
Clean array
Copy array back to source range
Split data into multiple columns using TextToColumns
Sub MagicButton_Click2()
Dim arData
Dim LastRow As Long, i As Integer
Dim dataRange As Range
LastRow = Range("A" & rowS.Count).End(xlUp).Row
Set dataRange = Range(Cells(1, 1), Cells(LastRow, 1))
arData = dataRange.value
For i = 1 To UBound(arData)
arData(i, 1) = AlphaNumericOnly(CStr(arData(i, 1)))
Next
dataRange.value = arData
dataRange.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="{", TrailingMinusNumbers:=True
End Sub
' http://stackoverflow.com/questions/15723672/how-to-remove-all-non-alphanumeric-characters-from-a-string-except-period-and-sp
Function AlphaNumericOnly(strSource As String) As String
Dim i As Integer
Dim strResult As String
For i = 1 To Len(strSource)
Select Case Asc(Mid(strSource, i, 1))
Case 48 To 57, 65 To 90, 97 To 123: 'include 32 if you want to include space I added 123 to include the {
strResult = strResult & Mid(strSource, i, 1)
End Select
Next
AlphaNumericOnly = strResult
End Function
I am currently trying to make a macro that will go to a directory, open a workbook (there are 38 currently with an eventual total of 52), filter two columns, get the total (repeat this 4 times), and the close the workbook. Currently it takes my application about 7 minutes just to process the current 38 workbooks.
How can I speed this up? I have already disables screen updating, events, and I changed the calculation methods to xlCalculationManual. I don't know if it common practice but I have seen people asking about a way to access a workbook without it being open but the suggestion to turn off screen updating is always made, which I have done.
When I run it in debug mode the Workbooks.Open() can take up to 10 seconds. The file directory is actually on a company network but accessing the file normally barely takes any time, under 5 seconds.
The data in the workbooks can contain the same points but at a different status. I do not think combining all of the data into one workbook would be possible.
I am going to experiment with direct cell references. Once I have some results I will update my post.
Private UNAME As String
Sub FileOpenTest()
Call UserName
Dim folderPath As String
Dim filename As String
Dim tempFile As String
Dim wb As Workbook
Dim num As Integer
Dim values(207) As Variant
Dim arryindex
Dim numStr As String
Dim v As Variant
Dim init As Integer
init = 0
num = 1
arryindex = 0
numStr = "0" & CStr(num)
'Initialize values(x) to -1
For Each v In values
values(init) = -1
init = init + 1
Next
With Excel.Application
.ScreenUpdating = False
.Calculation = Excel.xlCalculationManual
.EnableEvents = False
.DisplayAlerts = False
End With
'File path to save temp file
tempFile = "C:\Users\" & UNAME & "\Documents\TEMP.xlsm"
'Directory of weekly reports
folderPath = "path here"
'First file to open
filename = Dir(folderPath & "file here" & numStr & ".xlsm")
Do While filename <> ""
Set wb = Workbooks.Open(folderPath & filename)
'Overwrite previous "TEMP.xlsm" workbook without alert
Application.DisplayAlerts = False
'Save a temporary file with unshared attribute
wb.SaveAs filename:=tempFile, AccessMode:=xlExclusive
'operate on file
Filters values, arryindex
wb.Close False
'Reset file name
filename = Dir
'I use this loop to add the appropriate number to the end ie 01, 02, 03 etc
If num >= 9 Then
num = num + 1
If num = 33 Then
num = num + 1
End If
numStr = CStr(num)
ElseIf num < 9 Then
num = num + 1
numStr = "0" & CStr(num)
End If
filename = Dir(folderPath & "filename here" & numStr & ".xlsm")
Loop
output values
'Delete "TEMP.xlsm" file
On Error Resume Next
Kill tempFile
On Error GoTo 0
End Sub
Function Filters(ByRef values() As Variant, ByRef arryindex)
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
'filter column1
ActiveSheet.Range("B6").End(xlDown).AutoFilter Field:=2, Criteria1:=Array( _
"p1", "p2", "p3", "p4", "p5"), Operator:=xlFilterValues
'filter column2
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:=Array( _
"s1", "d2", "s3"), Operator:=xlFilterValues
'get the total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
'filter column2 for different criteria
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:="s"
'filter colum3 for associated form
ActiveSheet.Range("AZ6").End(xlDown).AutoFilter Field:=52, Criteria1:="<>"
'get the total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
'filter coum 3 for blank forms
ActiveSheet.Range("AZ6").End(xlDown).AutoFilter Field:=52, Criteria1:="="
'get the total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
'filter for column4 if deadline was made
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=52
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:=Array( _
"s1", "s2", "s3", "s4", "s5", "s6"), Operator:=xlFilterValues
ActiveSheet.Range("BC6").End(xlDown).AutoFilter Field:=55, Criteria1:=RGB(146 _
, 208, 80), Operator:=xlFilterCellColor
'get total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
End Function
Public Function TotalCount() As Integer
Dim rTable As Range, r As Range, Kount As Long
Set rTable = ActiveSheet.AutoFilter.Range
TotalCount = -1
For Each r In Intersect(Range("A:A"), rTable)
If r.EntireRow.Hidden = False Then
TotalCount = TotalCount + 1
End If
Next
End Function
Function UserName() As String
UNAME = Environ("USERNAME")
End Function
Function output(ByRef values() As Variant)
Dim index1 As Integer
Dim index2 As Integer
Dim t As Range
Dim cw As Integer
'Calendar week declariations
Dim cwstart As Integer
Dim cstart As Integer
Dim cstop As Integer
Dim data As Integer
data = 0
start = 0
cw = 37
cstart = 0
cstop = 3
ThisWorkbook.Sheets("Sheet1").Range("B6").Activate
For index1 = start To cw
For index2 = cstart To cstop
Set t = ActiveCell.Offset(rowOffset:=index1, columnOffset:=index2)
t.value = values(data)
data = data + 1
Next
Next
End Function
In general there are five rules to making Excel-VBA macros fast:
Don't use .Select methods,
Don't use Active* objects more than once,
Disable screen-updating and automatic calculations,
Don't use visual Excel methods (like Search, Autofilter, etc),
And most of all, always use range-array copying instead of browsing individual cells in a range.
Of these, you have only implemented #3. Additionally, you are exacerbating things by re-Saving your worksheets, just so that you can execute Visual modification methods (AutoFilter in your case). What you need to do to make it fast is to first implement the rest of these rules, and secondly, stop modifying your source worksheets so that you can open them read-only.
The core of what's causing your problems and forcing all of these other undesirable decisions is how you have implemented the Filters function. Instead of trying to do everything with the visual Excel functions, which are slow compared to (well-written) VBA (and that modify the worksheets, forcing your redundant Saves), just range-array copy all of the data you need from the sheet and use straight-forward VBA code to do your counting.
Here is an example of your Filters function that I converted to these principles:
Function Filters(ByRef values() As Variant, ByRef arryindex)
On Error GoTo 0
Dim ws As Worksheet
Set ws = ActiveSheet
'find the last cell that we might care about
Dim LastCell As Range
Set LastCell = ws.Range("B6:AZ6").End(xlDown)
'capture all of the data at once with a range-array copy
Dim data() As Variant, colors() As Variant
data = ws.Range("A6", LastCell).Value
colors = ws.Range("BC6", "BC" & LastCell.Row).Interior.Color
' now scan through every row, skipping those that do not
'match the filter criteria
Dim r As Long, c As Long, v As Variant
Dim TotCnt1 As Long, TotCnt2 As Long, TotCnt3 As Long, TotCnt4 As Long
TotCnt1 = -1: TotCnt2 = -1: TotCnt3 = -1: TotCnt4 = -1
For r = 1 To UBound(data, 1)
'filter column1 (B6[2])
v = data(r, 2)
If v = "p1" Or v = "p2" Or v = "p3" Or v = "p4" Or v = "p5" Then
'filter column2 (J6[10])
v = data(r, 10)
If v = "s1" Or v = "d2" Or d = "s3" Then
'get the total of points
TotCnt1 = TotCnt1 + 1
End If
'filter column2 for different criteria
If data(r, 10) = "s" Then
'filter colum3 for associated form
If CStr(data(r, 52)) <> "" Then
'get the total of points
TotCnt2 = TotCnt2 + 1
Else
' filter coum 3 for blank forms
'get the total of points
TotCnt3 = TotCnt3 + 1
End If
End If
'filter for column4 if deadline was made
v = data(r, 10)
If v = "s1" Or v = "s2" Or v = "s3" Or v = "s4" Or v = "s5" Then
If colors(r, 1) = RGB(146, 208, 80) Then
TotCnt4 = TotCnt4 + 1
End If
End If
End If
Next r
values(arryindex) = TotCnt1
values(arryindex + 1) = TotCnt2
values(arryindex + 2) = TotCnt3
values(arryindex + 3) = TotCnt4
arryindex = arryindex + 4
End Function
Please note that because I cannot test this for you and also because there is a lot of implicitness to the Autofilter/Range effects in the original code, I cannot tell if it is correct. You will have to do that.
Note: If you do decided to implement this, please let us know what impact it had, if any. (I try to keep track of what works and how much)
enter code hereI have my following code a bit short in the process of working on it, so I am trying to get text from a .txt file to be displayed in a cell on Excel, the code will be
Sub citi()
Dim c As Range
Open "C:\Users\alvaradod\Desktop\citi macro\Import File.txt" For Input As #1
R = 0
Dim i As Range
Dim num As Integer
Dim arrData() As String
the_value = Sheets("Prog").Range("A1")
Do Until EOF(1)
Line Input #1, Data
If Not Left(Data, 1) = "" Then
'import this row
R = R + 1
Cells(R, 1).Value = Data
'Mid(the_value, 3, 5)
'Left(Data, Len(Data) - 3)).Value
End If
Loop
For Each i In Range("A1")
i.Select
ActiveCell.Rows("1:1").Mid(Data(i), 49, 5).Select
'ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Sheets("Import").Range("A1").End(xlUp).Offset(num, 0).PasteSpecial
ActiveCell.Rows.Delete
num = num + 1
Next i
End Sub
" LINE 11 WILL PAST THE TEXT FROM LINE ONE ON .TXT FILE TO EXCEL, AFTER THIS FUNCTION I NEED TO TRIM THIS SAME TEXT IN THE EXCEL SHEET TO SHOW THE FIRST 5 CHARACTERS"
Your question isn't very clear, but perhaps something like this?
Sub citi()
Dim oFSO As Object
Dim arrData() As String
Dim arrImport1(1 To 65000) As String
Dim arrImport2(1 To 65000) As String
Dim i As Long, j As Long
Set oFSO = CreateObject("Scripting.FileSystemObject")
arrData = Split(oFSO.OpenTextFile("C:\Test\test.txt").ReadAll, vbCrLf)
For i = LBound(arrData) To UBound(arrData)
If Len(arrData(i)) > 0 Then
j = j + 1
arrImport1(j) = Mid(arrData(i), 3, 5)
arrImport2(j) = Mid(arrData(i), 49, 5)
End If
Next i
If j > 0 Then
Sheets("Sheet1").Range("A1").Resize(j).Value = Application.Transpose(arrImport1)
Sheets("Sheet2").Range("A1").Resize(j).Value = Application.Transpose(arrImport2)
End If
Set oFSO = Nothing
Erase arrData
Erase arrImport
End Sub