Related
Need help from Array VBA expert. Instead of formatting each cell in a range as per code below, is it possible to get this format included in Array so that once it write back to range it is formatted at the same time of writing?
Note that each item in oArr has varying formats as shown below
The current output once I run the code below
Option Explicit
Sub Write_Array_With_Format()
Dim xArr, aArr, bArr, sArr(), oArr() As Variant, lRow, i As Long, x, A, B As Double
With Worksheets("Data") 'set data ranges to array
lRow = .Cells(Rows.Count, 2).End(xlUp).Row
xArr = .Range(.Cells(6, 2), .Cells(lRow, 2)).Value2
aArr = .Range(.Cells(6, 3), .Cells(lRow, 3)).Value2
bArr = .Range(.Cells(6, 4), .Cells(lRow, 4)).Value2
End With
ReDim sArr(LBound(xArr, 1) To UBound(xArr, 1), 1 To 1) 'String Array
sArr = Array("x A B", "A x B", "A B x", "x B A", "B x A", "B A x")
sArr = Application.Transpose(sArr)
ReDim oArr(LBound(xArr, 1) To UBound(xArr, 1), 1 To 1) 'Output Array
For i = 1 To UBound(xArr, 1)
x = xArr(i, 1): A = aArr(i, 1): B = bArr(i, 1)
If x > A And x > B And A > B Then
oArr(i, 1) = sArr(1, 1)
ElseIf x < A And x > B And A > B Then
oArr(i, 1) = sArr(2, 1)
ElseIf x < A And x < B And A > B Then
oArr(i, 1) = sArr(3, 1)
ElseIf x > A And x > B And A < B Then
oArr(i, 1) = sArr(4, 1)
ElseIf x > A And x < B And A < B Then
oArr(i, 1) = sArr(5, 1)
ElseIf x < A And x < B And A < B Then
oArr(i, 1) = sArr(6, 1)
End If
Next
With Worksheets("Data")
.Range(.Cells(6, 5), .Cells(lRow, 5)).Value2 = oArr 'write Output Array to Range
For i = 6 To lRow 'Format values
If .Range("E" & i).Value = "x A B" Then
With .Range("E" & i)
With .Characters(1, 1).Font
.Color = vbBlue
End With
With .Characters(3, 3).Font
.Underline = True
.Color = vbGreen
End With
End With
ElseIf .Range("E" & i).Value = "A x B" Then
With .Range("E" & i)
With .Characters(1, 2).Font
.Color = vbGreen
.Underline = True
End With
With .Characters(3, 1).Font
.Underline = True
.Color = vbBlue
End With
With .Characters(5, 1).Font
.Color = vbGreen
End With
End With
'And so on and so forth.............
End If
Next
End With
End Sub
Please, try using the next approach. The code will iterate between the array elements, but it is not possible to keep format in an array... It will process each array element, only incrementing its rows, according to each case definition (in a separate Sub):
Sub testCellFormat()
'Dim dict As New Scripting.Dictionary, i As Long
Dim sh As Worksheet, lastR As Long, arr, oArr, sArr, arrFin, i As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
sh.Range("E6:E" & lastR).Font.Color = vbBlack 'just to reset the range for the second test...
sh.Range("E6:E" & lastR).Font.Underline = False
arr = sh.Range("B6:D" & lastR).Value2 'place all the range in a single aray
sArr = Array("x A B", "A x B", "A B x", "x B A", "B x A", "B A x") 'A 1 D array is good enough, too
ReDim oArr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
If arr(i, 1) > arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) > arr(i, 3) Then
oArr(i, 1) = sArr(0)
ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) > arr(i, 3) Then
oArr(i, 1) = sArr(1)
ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) > arr(i, 3) Then
oArr(i, 1) = sArr(2)
ElseIf arr(i, 1) > arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) < arr(i, 3) Then
oArr(i, 1) = sArr(3)
ElseIf arr(i, 1) > arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) < arr(i, 3) Then
oArr(i, 1) = sArr(4)
ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) < arr(i, 3) Then
oArr(i, 1) = sArr(5)
End If
Next
sh.Range("E" & 6).Resize(UBound(oArr), 1).value = oArr 'drop the array content
For i = 1 To UBound(oArr)
cellFormat sh.Range("E" & i + 5) 'process the necessary range (built using the iteration variable)
Next i
End Sub
Sub cellFormat(rngE As Range)
Dim T As String: T = rngE.value
Dim boolUnderscore, boolGreen, boolRed, boolBlue
If Len(T) <> 5 Then Exit Sub
Select Case left(T, 3)
Case "x A"
rngE.Characters(1, 1).Font.Color = vbBlue
With rngE.Characters(3, 3).Font
.Color = vbGreen
.Underline = True
End With
Case "A x"
rngE.Characters(1, 3).Font.Underline = True
rngE.Characters(1, 2).Font.Color = vbGreen
rngE.Characters(3, 3).Font.Color = vbBlue
rngE.Characters(5, 1).Font.Color = vbGreen
Case "A B"
rngE.Characters(1, 4).Font.Color = vbGreen
rngE.Characters(5, 1).Font.Color = vbBlue
rngE.Characters(3, 3).Font.Underline = True
Case "x B"
rngE.Characters(1, 3).Font.Underline = True
rngE.Characters(1, 1).Font.Color = vbBlue
rngE.Characters(2, 5).Font.Color = vbRed
Case "B x"
rngE.Characters(3, 5).Font.Underline = True
rngE.Font.Color = vbRed
rngE.Characters(3, 1).Font.Color = vbBlue
Case "B A"
With rngE.Characters(1, 3).Font
.Color = vbRed
.Underline = True
End With
rngE.Characters(5, 1).Font.Color = vbBlue
End Select
End Sub
I asked about the occurrences number of the same string type. If there are many, the code can be optimized (I can do that) to use a dictionary where to keep a Union range to be formatted at once, of the end. But pere every category type. If not too many cases for the same string type, not much to be gain...
According to the used algorithm, the string types used by the second sub, can be kept in an array and use them a little more efficient.
Edited:
Please, try the following optimized solution. It will firstly place the unique strings from oArr (col E:E) in a dictionary (as keys) and as items Union ranges of (built) similar cells (in E:E). Then, it will process/format the Union ranges, at once:
Sub testCellFormat()
Dim sh As Worksheet, lastR As Long, arr, oArr, sArr, arrFin, i As Long
Dim dict As Object ' New Scripting.Dictionary
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
sh.Range("E6:E" & lastR).Font.Color = vbBlack 'just to reset the range for the second test...
sh.Range("E6:E" & lastR).Font.Underline = False
arr = sh.Range("B6:D" & lastR).Value2 'place all the range in a single aray
sArr = Array("x A B", "A x B", "A B x", "x B A", "B x A", "B A x") 'a 1 D array is good enough, too
ReDim oArr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr) 'iterate between the array rows and appropriately fill oArr elements:
If arr(i, 1) > arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) > arr(i, 3) Then
oArr(i, 1) = sArr(0)
ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) > arr(i, 3) Then
oArr(i, 1) = sArr(1)
ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) > arr(i, 3) Then
oArr(i, 1) = sArr(2)
ElseIf arr(i, 1) > arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) < arr(i, 3) Then
oArr(i, 1) = sArr(3)
ElseIf arr(i, 1) > arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) < arr(i, 3) Then
oArr(i, 1) = sArr(4)
ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) < arr(i, 3) Then
oArr(i, 1) = sArr(5)
End If
Next
sh.Range("E" & 6).Resize(UBound(oArr), 1).Value2 = oArr 'drop the array content
'place the not formatted range in a dictionary. Keys as oArr elements and items as (Union) build range:
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
If Not dict.Exists(oArr(i, 1)) Then
dict.Add oArr(i, 1), sh.Range("E" & i + 5)
Else
Set dict(oArr(i, 1)) = Union(dict(oArr(i, 1)), sh.Range("E" & i + 5))
End If
Next
'some optimization
With Application
.ScreenUpdating = False:
.Calculation = xlCalculationManual
.EnableEvents = False
End With
For i = 1 To UBound(oArr) 'iterate between oArr rows
cellFormatDict CStr(oArr(i, 1)), sArr, dict 'format each dictionary Union ranges, at once
Next i
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
MsgBox "Ready...", vbInformation, "Job done."
End Sub
Sub cellFormatDict(strCond As String, sArr, dict As Object)
Select Case left(dict(strCond), 3)
Case left(sArr(0), 3) ' "x A"
With dict(strCond)
.Characters(1, 1).Font.Color = vbBlue
With .Characters(3, 3).Font
.Color = vbGreen
.Underline = True
End With
End With
Case left(sArr(1), 3) ' "A x"
With dict(strCond)
.Characters(1, 3).Font.Underline = True
.Characters(1, 2).Font.Color = vbGreen
.Characters(3, 3).Font.Color = vbBlue
.Characters(5, 1).Font.Color = vbGreen
End With
Case left(sArr(2), 3) ' "A B"
With dict(strCond)
.Characters(1, 4).Font.Color = vbGreen
.Characters(5, 1).Font.Color = vbBlue
.Characters(3, 3).Font.Underline = True
End With
Case left(sArr(3), 3) ' "x B"
With dict(strCond)
.Characters(1, 3).Font.Underline = True
.Characters(1, 1).Font.Color = vbBlue
.Characters(2, 5).Font.Color = vbRed
End With
Case left(sArr(4), 3) ' "B x"
With dict(strCond)
.Characters(3, 5).Font.Underline = True
.Font.Color = vbRed
.Characters(3, 1).Font.Color = vbBlue
End With
Case left(sArr(5), 3) ' "B A"
With dict(strCond)
With .Characters(1, 3).Font
.Color = vbRed
.Underline = True
End With
.Characters(5, 1).Font.Color = vbBlue
End With
End Select
End Sub
Its efficiency will be more visible in big ranges having more occurrences of the same strings (in E:E).
Please, test both versions and send feedback about the efficiency difference.
In order to rapidly create a testing environment, I created the next sub to multiply the existing (shown) testing range. Multiplying it by 500 times, I obtained a range of 3004 rows, which could be processed in about 30 seconds. Changing the format is something consuming time... Using the Union ranges looks to be the single way to make a relatively fast code for such a purpose, I think.
In an effort to streamline my efforts for a data transfer macro, I have moved to arrays. I have limited experience with them, let alone vba. But I was able to build it, and have it write. The last hurdle I have is that I am unable to specify which values to write, as I only need them transferred if they are over or under a certain amount; i.e. array(dem2, 6) = >300 write, array(dem2, 6) = <300 don't write.
Long story short, I want to be able to write data for rows where that value is either >300 or <-300.
I spent several hours reading posts, trying various loops and conditions including do, do while, goto, elseif but none seem to work and cause errors to pop up.
Public wbFr As Workbook
Public wbTo As Workbook
Public wsFr As Worksheet
Public wsTo As Worksheet
Option Explicit
Public Sub MoveToLogBookArray()
'==================================
' Macro to put data in array '
' Then write to separate workbook '
'==================================
Dim FromArr() As Variant
Dim Dem1 As Long, Dem2 As Long 'Multi-dimensional
Dim lastRow As Long
Dim LR As Long
Dim i As Long
Dim j As Long
Dim test As Boolean
'==================
'Workbook with data
Set wbFr = Workbooks("Book1useV2.xlsm")
'====================
'Destination workbook
Set wbTo = Workbooks("Book2V2.xlsm")
'============
'Source sheet
Set wsFr = wbFr.Worksheets("test")
'=================
'Destination sheet
Set wsTo = wbTo.Worksheets("Sheet7")
With wsFr 'Attempt at setting bounds of array
Dem1 = Range("A2:A10").Cells.Count - 1 '# of rows
Dem2 = Range("A2:A10").Cells.Count - 3 '# of columns
ReDim FromArr(0 To Dem1, 0 To Dem2)
For Dem1 = LBound(FromArr, 1) To UBound(FromArr, 1)
For Dem2 = LBound(FromArr, 2) To UBound(FromArr, 2)
FromArr(Dem1, Dem2) = wsFr.Range("A2").Offset(Dem1, Dem2)
Next Dem2
Next Dem1
End With
'Successfully builds array
'=========================
'Find last row of destination sheet to go to next empty row
With wsTo
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
Else
lastRow = 1
End If
End With
'================================================================
With wsTo
j = lastRow + 1
For i = LBound(FromArr) To UBound(FromArr)
test = True
If FromArr(Dem2, 6) <= 300 Then test = False 'Inputting .value gives error
'do nothing '"Object required"
If FromArr(Dem2, 6) >= 300 Then test = True
If test = False Then
wsTo.Cells(j, 1) = FromArr(i, 0)
wsTo.Cells(j, 2) = FromArr(i, 1)
wsTo.Cells(j, 3) = FromArr(i, 2)
wsTo.Cells(j, 4) = FromArr(i, 3)
wsTo.Cells(j, 10) = FromArr(i, 4)
wsTo.Cells(j, 13) = FromArr(i, 5)
wsTo.Cells(j, 17) = FromArr(i, 6)
j = j + 1
End If '=======================================================
Next i 'I'm unable to write only values over 300 or under -300]
End With '=======================================================
Exit Sub
End Sub
As mentioned above, I want to be able to specify rows of values input into an array in one workbook, then write them to a separate workbook based on conditions of column 6.
With wsTo 'set break here
j = lastRow + 1
For i = LBound(FromArr) To UBound(FromArr)
test = (FromArr(Dem2, 6) <= -300) And (FromArr(Dem2, 6) >= 300) '= True/False
'tried both false/true and commented out^^^^^
'and flipping <, >
If test = True Then
'do nothing
End If
'When it writes, it writes all values or no values at all
'````````````````````````````````````````````````````````
If test = False Then 'values for 4&5 include decimals
wsTo.Cells(j, 1) = FromArr(i, 0) 'type= variant/double
wsTo.Cells(j, 2) = FromArr(i, 1) 'type= variant/string
wsTo.Cells(j, 3) = FromArr(i, 2) 'type= variant/string
wsTo.Cells(j, 4) = FromArr(i, 3) 'type= variant/string
wsTo.Cells(j, 10) = FromArr(i, 4) 'type= variant/double
wsTo.Cells(j, 13) = FromArr(i, 5) 'type= variant/double
wsTo.Cells(j, 17) = FromArr(i, 6) 'type= variant/double
j = j + 1 'On 4th iteration, value is 285 but is written anyway
End If
'=======================================================
Next i 'I'm unable to write only values over 300 or under -300]
End With '=======================================================
Exit Sub
'Values in test Column
'517.34
'733.68
'312.26
'285.00 writes regardless
'297.00 ""
'312.00
'333.00
'250.00 ""
'500.00
End Sub
And here is my finished working project thanks to Robert and Patrick.
Public wbFr As Workbook
Public wbTo As Workbook
Public wsFr As Worksheet
Public wsTo As Worksheet
Option Explicit
Public Sub MoveToLogBookArray()
'==================================
' Macro to put data in array '
' Then write to separate workbook '
'==================================
Dim FromArr() As Variant
Dim lastRow As Long
Dim i As Long
Dim j As Long
Dim test As Boolean
'==================
'Workbook with data
Set wbFr = Workbooks("Book1useV2.xlsm")
'====================
'Destination workbook
Set wbTo = Workbooks("Book2V2.xlsm")
'============
'Source sheet
Set wsFr = wbFr.Worksheets("test")
'=================
'Destination sheet
Set wsTo = wbTo.Worksheets("Sheet7")
'========================================================================
With wsFr 'Attempt at setting bounds of array
FromArr = Range("adjRange")
End With
With wsTo
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
Else
lastRow = 1
End If
End With
'===================================================================
'Be sure to verify parameters
'Check for errors
On Error GoTo ErrHandler
With wsTo
j = lastRow + 1
For i = LBound(FromArr) To UBound(FromArr)
test = False
If FromArr(i, 6) >= 300 And FromArr(i, 6) <= -300 Then test = False
If FromArr(i, 6) < 299.99 And FromArr(i, 6) > -299.99 Then test = True
If test = False Then
wsTo.Cells(j, 1) = FromArr(i, 1)
wsTo.Cells(j, 2) = FromArr(i, 2)
wsTo.Cells(j, 3) = FromArr(i, 3)
wsTo.Cells(j, 4) = FromArr(i, 4)
wsTo.Cells(j, 10) = FromArr(i, 5)
wsTo.Cells(j, 13) = FromArr(i, 6)
wsTo.Cells(j, 17) = FromArr(i, 7)
j = j + 1
End If
Next i
End With
On Error GoTo 0
'===================================================================
Exit Sub
ErrHandler:
MsgBox "An error has occurred! Please check values are in correct column. " & Err.Description
Exit Sub
End Sub
This should work. You had a typo in the index to the FromArr(). I could not run it, so let me know if it does not work.
With wsTo
j = lastRow + 1
For i = LBound(FromArr, 1) To UBound(FromArr2, 1)
If FromArr(i, 6) <= 300 Then test = False
If FromArr(1, 6) > 300 Then test = True
If test = False Then
wsTo.Cells(j, 1) = FromArr(i, 0)
wsTo.Cells(j, 2) = FromArr(i, 1)
wsTo.Cells(j, 3) = FromArr(i, 2)
wsTo.Cells(j, 4) = FromArr(i, 3)
wsTo.Cells(j, 10) = FromArr(i, 4)
wsTo.Cells(j, 13) = FromArr(i, 5)
wsTo.Cells(j, 17) = FromArr(i, 6)
j = j + 1
End If
Next i
End With
I'm struggling with understanding why this doesn't work...The code doesn't crash but in the Watch window each value of the VLookUpsStorer are "Error 2042".
Can someone help me spot the error ?
Dim I As Long
Dim VLookUpsStorer As Variant
ReDim VLookUpsStorer(1 To Range("A" & Rows.Count).End(xlUp).Row - 1, 1 To 3) As Variant
Dim TotalRows As Integer
TotalRows = Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row
Worksheets("Sheet2").Activate
With Sheets("Sheet1")
For I = 2 To Range("A" & Rows.Count).End(xlUp).Row
If Worksheets("Sheet2").Range("A" & I) <> "" Then
VLookUpsStorer(I - 1, 1) = Application.VLookup(Worksheets("Sheet2").Range("A" & I), .Range("C2:D" & TotalRows), 2, False)
VLookUpsStorer(I - 1, 2) = Application.VLookup(Worksheets("Sheet2").Range("A" & I), .Range("C2:E" & TotalRows), 3, False
VLookUpsStorer(I - 1, 3) = Application.VLookup(Worksheets("Sheet2").Range("A" & I), .Range("C2:F" & TotalRows), 4, False)
Else
Exit For
End If
Next I
End With
Range(Cells(2, 7), Cells(Range("A" & Rows.Count).End(xlUp).Row, 9)) = VLookUpsStorer
EDIT : Tests done
EDIT 2 : Sample of what the 2 sheets look like (before I put them both with the same General format (but no differences))
Sheet1
Sheet2
I am trying to get the information from one workbook, transform it to array (2D), add the first column (identifier) to an identifier array, match and paste it to excel. The code has some extra lines for basic organization.
The current problem is that, in the IsInArray function, I am getting a "subscript not defined", for the 'for position = LBound(arr) to UBound(arr)'.
Any idea of what might be happening?
Sub Pr()
Dim w As Workbook
Set w = ThisWorkbook
Dim w2 As Workbook
Dim end1 As Long, end2 As Long, i As Long, lRow As Long, lColumn As Long, t As Long, k As Long, position As Long, g As Long
Dim WBArray() As Variant
Dim IS() As Variant
Dim ws As Worksheet
end1 = ThisWorkbook.Worksheets(1).UsedRange.Rows.count
Dim MyFolder As String
Dim MyFile As String
'Optimize Macro Speed Start
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'opens the first workbook file
For i = 2 To ThisWorkbook.Sheets("FILES").Cells(1, 2).Value
Workbooks.Open Filename:=ThisWorkbook.path & "\" & ThisWorkbook.Sheets("FILES").Cells(i, 1).Value
Set w2 = ActiveWorkbook
ActiveSheet.Range("A:A").Select
'text to columns
Selection.TextToColumns destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7 _
, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17 _
, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27 _
, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1)), TrailingMinusNumbers:=True
end2 = ActiveSheet.UsedRange.Rows.count
'transform it to array
WBArray = ActiveSheet.Range(Cells(5, 1), Cells(end2, 29)).Value
'loop to match information in two arrays
For lRow = 2 To UBound(WBArray)
If IsInArray((WBArray(lRow, 1)), IS) <> -1 Then
t = IsInArray((WBArray(lRow, 1)), IS)
'start the information pasting procedure:
w.Sheets("C").Cell(t, i + 3) = WBArray(lRow, 11)
w.Sheets("M").Cell(t, i + 3) = WBArray(lRow, 12)
w.Sheets("W t-1").Cell(t, i + 3) = WBArray(lRow, 13)
w.Sheets("P").Cell(t, i + 3) = WBArray(lRow, 14)
w.Sheets("A").Cell(t, i + 3) = WBArray(lRow, 15)
w.Sheets("PC").Cell(t, i + 3) = WBArray(lRow, 16)
w.Sheets("AM").Cell(t, i + 3) = WBArray(lRow, 17)
w.Sheets("AM t-1").Cell(t, i + 3) = WBArray(lRow, 18)
w.Sheets("P t-1").Cell(t, i + 3) = WBArray(lRow, 19)
w.Sheets("F").Cell(t, i + 3) = WBArray(lRow, 20)
w.Sheets("F t-1").Cell(t, i + 3) = WBArray(lRow, 21)
w.Sheets("A t-1").Cell(t, i + 3) = WBArray(lRow, 22)
w.Sheets("S").Cell(t, i + 3) = WBArray(lRow, 23)
Else
'add it to the end of ISArray
ReDim Preserve IS(1 To UBound(IS) + 1)
IS(UBound(IS)) = WBArray(lRow, 1)
k = UBound(IS)
w.Sheets("C").Cell(k, i + 3) = WBArray(lRow, 11)
w.Sheets("M").Cell(k, i + 3) = WBArray(lRow, 12)
w.Sheets("W t-1").Cell(k, i + 3) = WBArray(lRow, 13)
w.Sheets("P").Cell(k, i + 3) = WBArray(lRow, 14)
w.Sheets("A").Cell(k, i + 3) = WBArray(lRow, 15)
w.Sheets("PC").Cell(k, i + 3) = WBArray(lRow, 16)
w.Sheets("AM").Cell(k, i + 3) = WBArray(lRow, 17)
w.Sheets("AM t-1").Cell(k, i + 3) = WBArray(lRow, 18)
w.Sheets("P t-1").Cell(k, i + 3) = WBArray(lRow, 19)
w.Sheets("F").Cell(k, i + 3) = WBArray(lRow, 20)
w.Sheets("F t-1").Cell(k, i + 3) = WBArray(lRow, 21)
w.Sheets("A t-1").Cell(k, i + 3) = WBArray(lRow, 22)
w.Sheets("S").Cell(k, i + 3) = WBArray(lRow, 23)
End If
Next lRow
'copy the file date from each source workbook to output workbook
'if the control sheet name (FILES) is changed, please change it in this loop
For Each ws In w.Worksheets
If ws.Name <> "FILES" Then
ws.Cells(1, i + 3) = w2.Worksheets(1).Cells(1, 2)
End If
Next ws
Next i
'paste the is array to all worksheets
g = UBound(IS)
For Each ws In ActiveWorkbook.Worksheets
Range("A1:A" & g) = IS()
Next ws
'Optimize Macro Speed
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
'Close file and save
'w.Close True
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim position As Long
'default return value if value not found in array
IsInArray = -1
For position = LBound(arr) To UBound(arr) 'subscript out of range
If arr(position) = stringToBeFound Then
IsInArray = position + 1
Exit For
End If
Next
End Function
Your problem is that when you test the LBOUND of an unallocated array, you will get an error. And that will be the case on the first pass through your IsInArray function.
Since links to outside websites are discouraged, I have copied the IsArrayEmpty function from Chip Pearson's web site page on VBA Arrays
Change your IsInArray function as follows (and add the IsArrayEmpty function as I show below:
Function IsInArray(stringToBeFound As String, Arr As Variant) As Long
Dim position As Long
'default return value if value not found in array
IsInArray = -1
If IsArrayEmpty(Arr) Then Exit Function
For position = LBound(Arr) To UBound(Arr) 'subscript out of range
If Arr(position) = stringToBeFound Then
IsInArray = position + 1
Exit For
End If
Next
End Function
Public Function IsArrayEmpty(Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'From Chip Pearson [VBA Arrays](http://www.cpearson.com/excel/vbaarrays.htm)
' IsArrayEmpty
' This function tests whether the array is empty (unallocated). Returns TRUE or FALSE.
'
' The VBA IsArray function indicates whether a variable is an array, but it does not
' distinguish between allocated and unallocated arrays. It will return TRUE for both
' allocated and unallocated arrays. This function tests whether the array has actually
' been allocated.
'
' This function is really the reverse of IsArrayAllocated.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim LB As Long
Dim UB As Long
Err.Clear
On Error Resume Next
If IsArray(Arr) = False Then
' we weren't passed an array, return True
IsArrayEmpty = True
End If
' Attempt to get the UBound of the array. If the array is
' unallocated, an error will occur.
UB = UBound(Arr, 1)
If (Err.Number <> 0) Then
IsArrayEmpty = True
Else
''''''''''''''''''''''''''''''''''''''''''
' On rare occassion, under circumstances I
' cannot reliably replictate, Err.Number
' will be 0 for an unallocated, empty array.
' On these occassions, LBound is 0 and
' UBoung is -1.
' To accomodate the weird behavior, test to
' see if LB > UB. If so, the array is not
' allocated.
''''''''''''''''''''''''''''''''''''''''''
Err.Clear
LB = LBound(Arr)
If LB > UB Then
IsArrayEmpty = True
Else
IsArrayEmpty = False
End If
End If
End Function
In your function IsInArray, can you try this :
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim position As Long
Dim returnValue as Long
'default return value if value not found in array
returnValue = -1
For position = LBound(arr) To UBound(arr) 'subscript out of range
If arr(position) = stringToBeFound Then
returnValue = position + 1
Exit For
End If
Next
IsInArray = returnValue
End Function`
I think when you write : IsInArray = -1, you're ending your function.
I have written a VBA Macro which works, but takes too long because the database is also very big.
I know this can be optimized via Arrays, but I am not sure how to make it.
Could someone help me please?
'Identify how many rows are in the file
finalrow = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
'fill the empty fields which requires the part number and description
For i = 2 To finalrow
If Cells(i, 3) = 0 Or Cells(i, 3) = "------------" Or Cells(i, 3) = "e" Or Cells(i, 3) = "111)" Or Cells(i, 3) = "ion" Then
If Cells(i, 4) = 0 Or Cells(i, 4) = "-----------" Or Cells(i, 4) = "Location" Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
Else
For j = 1 To 3
Cells(i, j) = Cells(i - 1, j)
Next
End If
End If
If Cells(i, 1) = 0 Then
Cells(i, 1) = Cells(i - 1, 1)
End If
If Cells(i, 4) = 0 Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
End If
Count = Count + 1
If Count = finalrow Then
i = finalrow
End If
Next
I combined your code with my answer to excel Delete rows from table Macro based on criteria, that I just finished posting. It is super fast. Please check out my other answer for details.
You may need to adjust the Target range. If your data starts in A1 and does not have any completely blank rows than it should work.
Sub DeleteRows()
Dim Start: Start = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Const PreserveFormulas As Boolean = True
Dim Target As Range
Dim DeleteRow As Boolean
Dim Data, Formulas, NewData
Dim pos As Long, x As Long, y As Long
Set Target = Range("A1").CurrentRegion
Data = Target.Value
If PreserveFormulas Then Formulas = Target.Formula
ReDim NewData(1 To UBound(Data, 1), 1 To UBound(Data, 2))
For x = 2 To UBound(Data, 1)
DeleteRow = True
If Data(x, 3) = 0 Or Data(x, 3) = "------------" Or Data(x, 3) = "e" Or Data(x, 3) = "111)" Or Data(x, 3) = "ion" Then
If Data(x, 4) = 0 Or Data(x, 4) = "-----------" Or Data(x, 4) = "Location" Then
DeleteRow = False
End If
End If
If Data(x, 4) = 0 Or Data(x, 4) = "-----------" Or Data(x, 4) = "Location" Then DeleteRow = False
If Not DeleteRow Then
pos = pos + 1
For y = 1 To UBound(Data, 2)
If PreserveFormulas Then
NewData(pos, y) = Formulas(x, y)
Else
NewData(pos, y) = Data(x, y)
End If
Next
End If
Next
Target.Formula = NewData
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print "Execution Time: "; Timer - Start; " Second(s)"
End Sub
I'd start simply with this:
'Identify how many rows are in the file
finalrow = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
'fill the empty fields which requires the part number and description
For i = 2 To finalrow
Set ci3 = Cells(i, 3)
If ci3 = 0 Or ci3 = "------------" Or ci3 = "e" Or ci3 = "111)" Or ci3 = "ion" Then
Set ci4 = Cells(i, 4)
If ci4 = 0 Or ci4 = "-----------" Or ci4 = "Location" Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
Else
For j = 1 To 3
Cells(i, j) = Cells(i - 1, j)
Next
End If
End If
If Cells(i, 1) = 0 Then
Cells(i, 1) = Cells(i - 1, 1)
End If
If Cells(i, 4) = 0 Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
End If
Count = Count + 1
If Count = finalrow Then
i = finalrow
End If
Next