Can anyone please write this formula in VBA code, this is making the sheet heavy and whenever i add or edit raw data (Data sheet) it starts "Calculating 4 processors" and takes much time.
In raw Data Sheet there are almsot 18000 entries and in other sheet where i am extracting the status contains 8000 entries, however it would be much helpful if it sees till the last raw.
=IF(SUMPRODUCT((Data!$A$2:$A$17989=A7076)(Data!$B$2:$B$17989=B7076)(Data!$C$2:$C$17989="Combine")),"Available",IF(COUNTIFS(Data!$A$2:$A$17989,A7076,Data!$B$2:$B$17989,B7076,Data!$C$2:$C$17989,"Feed *")=2,"Available","Not Available"))
I have read many articles on web and tried them but not helpful and i am wondering if VBA is one of the best solution for this complex formula.
what i have recorded is below:
Sub Macro1()
'
ActiveCell.FormulaR1C1 = _
"=IF(SUMPRODUCT((Data!R2C1:R17989C1=RC[-5])*(Data!R2C2:R17989C2=RC[-4])*(Data!R2C3:R17989C3=""Combine"")),""Available"",IF(COUNTIFS(Data!R2C1:R17989C1,RC[-5],Data!R2C2:R17989C2,RC[-4],Data!R2C3:R17989C3,""Feed *"")=2,""Available"",""Not Available""))"
Range("F2").Select
Selection.Copy
Range("F3:F7076").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.End(xlUp).Select
Range("F3").Select
ActiveWorkbook.Save
End Sub
thank you
Please, test the next solution. Activate the sheet to be processed and run SetAvailability:
Sub SetAvailability()
Dim sh As Worksheet, shD As Worksheet, lastRA As Long, lastRD As Long, arrD, arr, arrF, i As Long
Set sh = ActiveSheet
Set shD = Worksheets("Data")
lastRA = sh.Range("A" & sh.rows.count).End(xlUp).Row
lastRD = shD.Range("A" & shD.rows.count).End(xlUp).Row
arrF = sh.Range("F2:F" & lastRA).Value2
arr = sh.Range("A2:B" & lastRA).Value2
arrD = shD.Range("A2:C" & lastRD).Value2
For i = 1 To UBound(arr)
arrF(i, 1) = getAvailability(arrD, arr(i, 1), arr(i, 2), "Combine", "Feed *")
Next i
'drop the processed aray content at once:
sh.Range("F2").Resize(UBound(arrF), 1).Value2 = arrF
MsgBox "Ready..."
End Sub
Function getAvailability(arrD, strAA, strBB, strAv As String, strFeed As String) As String
Dim countFeed As Long, i As Long
For i = 1 To UBound(arrD)
If arrD(i, 1) = strAA And UCase(arrD(i, 2)) = UCase(strBB) Then
If UCase(arrD(i, 3)) = UCase(strAv) Then getAvailability = "Available": Exit Function
If arrD(i, 3) Like strFeed Then countFeed = countFeed + 1
If countFeed = 2 Then getAvailability = "Available": Exit Function
End If
Next i
getAvailability = "Not Available"
End Function
It should be fast enough, working only in memory and dropping the processed array content at once, at the end of the code. And, no any workbook charge because of complicated formula...
The above solution assumes that strings as "Feed *" will be at least two, for matchings in A:A and B:B, meaning that more (than two) such matches are allowed to consider the return as "Available".
It will take some time, anyhow, but I am curious how match for your specific data ranges.
It will be faster if the availability is bigger (the iteration on "Data" sheet array stops after finding the match...).
Related
I've been looking for a solution to using .PasteSpecial more than once in a an excel vba macro.
I have reports that can sometimes have thousands of rows. In these reports are two columns, I need to merge these columns so that if one column has blanks, I want the value from the second column; otherwise, just keep the value in the first column. I need to apply this twice in two different places. This is all tucked into a larger code.
My solution is to utilize .PasteSpecial with "Skip Blanks". It is quick for excel to process, much faster than looping row by row. The problem is that the code keeps crashing excel.
After debugging, here is what I've learned so far:
*The first .PasteSpecial always works, but when it gets to the second .PasteSpecial it always fails.
*I've tried STOP after the first .PasteSpecial then step through the code, and after I step through the second.PasteSpecial the code works just fine.
*If I step through the second .PasteSpecial it works like nothing is wrong - but if I just run the code like normal it crashes.
*I switched the order of the two .PasteSpecials within the code. When I do this, it no longer crashes on the problematic .PasteSpecial, but it does crash on the originally working .PasteSpecial.
Based on this, I know the problem is Excel doesn't like .PasteSpecial twice in a code. Still cannot find a work around. I've tried emptying the clip board, and I don't know enough how to set up an array let alone if that is efficient for this much data. Anybody know of a solution or work around?
Here is my .PasteSpecial code:
MainSheet.Range("N:N").Copy
MainSheet.Range("P:P").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
MainSheet.Range("R:R").Copy
MainSheet.Range("Q:Q").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Your issue is that you are committing CPU to do OS level tasks when you don't actually need to paste anything.
The cells have values... so make them Equal and they... will... be...
Range("C1").Value = Range("A1").Value
Alternatively you can use a power query to just do this where Table 2 Col2 is null and ID = ID
Not needing format, please test the next code. It uses an array, not uses clipboard and is faster. If no need to exist a correspondence between the rows in the two filled columns, you can use the next fast way:
Sub copyColumnsArray()
Dim lastR As Long, arrCopy, arrFin, i As Long, k As Long
lastR = MainSheet.Range("N" & rows.count).End(xlUp).row
arr = MainSheet.Range("N1:N" & lastR).value
'fill another array only with non empty values:__________________
ReDim arrFin(UBound(arr) To 1): k = 1
For i = 1 To UBound(arrCopy)
If arrCopy(i, 1) <> "" Then arrFin(k, 1) = arrCopy(i, 1): k = k + 1
Next i
ReDim Preserve arrFin(k - 1 To 1)
'______________________________________________________
MainSheet.Range("P1").Resize(UBound(arrFin), 1).value = arrFin
lastR = MainSheet.Range("R" & rows.count).End(xlUp).row
arr = MainSheet.Range("R1:R" & lastR).value
'fill another array only with non empty values:__________________
ReDim arrFin(UBound(arr) To 1): k = 1
For i = 1 To UBound(arrCopy)
If arrCopy(i, 1) <> "" Then arrFin(k, 1) = arrCopy(i, 1): k = k + 1
Next i
ReDim Preserve arrFin(k - 1 To 1)
'______________________________________________________
MainSheet.Range("Q1").Resize(UBound(arrFin), 1).value = arrFin
End Sub
EDIT:
A better answer that worked more reliably than my original found solution is below. This is an adaptation of some advice from FaneDuru's answer. This solution is more taxing on resources; however, for now - it performs the task reliably (without crashing). I would love for there to be a better answers than row looping; however, this does answer my OP. Thank you for all the help!
Sub copyColumnsArray()
Dim lastR As Long, arrCopy
lastR = MainSheet.Range("N" & rows.count).End(xlUp).row
arrCopy = MainSheet.Range("N1:N" & lastR).value
Dim ArrayIndex as Variant
Dim RowCount as String
RowCount = 1
For Each ArrayIndex in arrCopy
If ArrayIndex = "" then
RowCount = RowCount +1
'Skip Blank
else
MainSheet.Range("P"+RowCount).value = ArrayIndex
RowCount = RowCount + 1
end if
Next
lastR = MainSheet.Range("R" & rows.count).End(xlUp).row
arrCopy = MainSheet.Range("R1:R" & lastR).value
RowCount = 1
For Each ArrayIndex in arrCopy
If ArrayIndex = "" then
RowCount = RowCount +1
'Skip Blank
else
MainSheet.Range("Q"+RowCount).value = ArrayIndex
RowCount = RowCount + 1
end if
Next
End Sub
I've been trying to figure this out, but had to luck.
I have a list that starts on A5 on worksheet2. I need to Vlookup each item from A5 down until the last cell in column A (list will never be the same size). The data/info will be on worksheet1. Then paste (as values) the data starting in cell C5 and until the last corresponding cell in column A.
The data on worksheet1 will most likely always been in columns A:L, but this could change so i'm hoping to make it dynamic where the code can know which column the data ends. Data will always start on A1.
I'm not sure how to loop this. Looking to achieve this through VBA using a macro-enabled button I started programming.
Thanks in advance!
sub lookup
dim x as long, lastrow as long
lastrow = Sheet2.cells(rows.count,1).end(xlup).row
for x = 5 to lastrow
Sheet2.Range("C" & x) = worksheetfunction.xlookup arg1:=sheet2.range("A" & x), _
arg2:= Sheet1.Range("A:A"), arg3:=Sheet1.range("B:B")
next x
end sub
I think you are going to need to solidify which column you are wanting to return in order to make the VBA simple. Depending on the column I think you can loop through until you find the header you are looking for, but it would be better if it was always in the same place.
This code says, for the sheet length of sheet2, starting in c5 xlookup your key, find it on sheet 1, and return the column that has your data.
It seems that you are looking for a row number in Worksheet1 and then intend to transfer all available data from that row. That would be a job for the MATCH worksheet function or Find in VBA. Please try the code below.
Sub MatchAndCopy()
' 213
Dim Rng As Range ' source data
Dim Arr As Variant ' one row of data
Dim Crit As Variant ' match criterium
Dim Fnd As Range ' match found
Dim R As Long ' loop counter: rows
Dim Spike As String ' collecting failures
Set Rng = Worksheets("Sheet1").UsedRange
Application.ScreenUpdating = False ' speed up execution
With Worksheets("Sheet2")
For R = 5 To .Cells(.Rows.Count, "A").End(xlUp).Row
Crit = .Cells(R, "A").Value
Set Fnd = Rng.Columns(1).Find(Crit, LookIn:=xlValues, LookAt:=xlWhole)
If Fnd Is Nothing Then
If Len(Spike) Then Spike = Spike & vbCr
Spike = Spike & String(5, " ") & """" & Crit & """ in row " & R
Else
Arr = Fnd.Offset(0, 1).Resize(1, Rng.Columns.Count - 1).Value
.Cells(R, 2).Resize(1, UBound(Arr, 2)).Value = Arr
End If
Next R
End With
Application.ScreenUpdating = True
If Len(Spike) Then
Spike = "Transfer of the following items failed." & vbCr & Spike
Else
Spike = "Data were transferred successfully and without errors."
End If
MsgBox Spike, vbInformation, "Transfer report"
End Sub
I have a lengthy code unable to share the 8000+ liner code completely, The code runs through loops multiple times row by row, if there are 10000+ rows then loop runs 10000+ times.
Since the code is too lengthy I am sharing a part of it were I feel it can shorten the time taken, But I am missing a loop in it and how do I include that Is my query for now.
I’ll be sharing the original code and very next is the replacement code kindly check and let me know we’re and how to include.
Original code:
For i = 2 To endlineMM
If worksheets(“MM Source”).cells(I,9).value = “registered locked” or worksheets(“MM Source”).cells(i,9).value = “registered unlocked” Then
For j = 3 to endlineDHDO
If instr(Lcase(worksheets(“DHDO”).cells(j,2).value),Lcase(Worksheets(“MM Source”).cells(i,2).value)) <> 0 Then
If Lcase(Worksheets(“MM Source”).cells(i,2).value) = Lcase(worksheets(“DHDO”).cells(j,2).value) Then
Found missing = True
Exit For
Else if j= EndlineDHDO And Lcase(Worksheets(“MM Source”).cells(i,2).value)<>
Lcase(worksheets(“DHDO”).cells(j,2).value) Then
Foundmissing = false
End if
Next j
If foundmissing = False Then
Etc......
Replacement code:
For i = 2 to endlineMM
If worksheets(“MM Source”).cells(I,9).value = “registered locked” or worksheets(“MM Source”).cells(i,9).value = “registered unlocked” Then
Test_ID = Worlsheets(“MM Source”).cells(i,2).value
With sheets(“DHDO”).Range(“B:B“)
Set prg = .Find(Test_ID, LookIn:=xlvalues)
If prg is nothing then
Foundmissing =true
Exit for
Else
Foundmissing = false
End if
End with
If foundmissing = false Then
Etc......
If you observe above from original code it has “i“ as well as “j” but in replacement code I am missing “j”
How can I fix my Replacement code
let me know how to edit the Replacement code please
Generally speaking, your code will run a lot faster if you use Ranges and Arrays rather than individual Cells.
For example, if you were to take a spreadsheet and fill columns A1:B10000, with numeric data, and then compare the performance of the two following codes:
Dim data As Variant
Dim output(10000) As Double
Dim i As Integer
data = Application.Transpose(Application.Transpose(Range("A1", "B10000")))
For i = 1 To 10000
output(i - 1) = data(i, 1) + data(i, 2)
Next
Range("C1", "C10000").Value = Application.Transpose(output)
and
Dim i As Integer
For i = 1 To 10000
Cells(i, 3).Value = Cells(i, 1).Value + Cells(i, 2).Value
Next
You will notice that the first variation is considerably faster.
By way of explanation Application.Transpose is necessary to assign the range to an array. It needs to be doubled in the first case, because it is a two-dimensional array.
Here is a sample that will filter the MM Source sheet, then loop through the visible cells finding cells in DHDO sheet
Sub Do_It()
Dim sh As Worksheet, ws As Worksheet
Dim rng As Range, c As Range
Dim a As Range
Set sh = Sheets("MM Source")
Set ws = Sheets("DHDO")
Application.ScreenUpdating = False
With sh
Set rng = .Range("I2:I" & .Cells(.Rows.Count, "I").End(xlUp).Row)
.Columns("I:I").AutoFilter Field:=1, Criteria1:= _
"=registered locked", Operator:=xlOr, Criteria2:="=registered unlocked"
For Each c In rng.SpecialCells(xlCellTypeVisible).Cells
Set a = ws.Range("B:B").Find(c.Offset(, -7), LookIn:=xlValues)
If Not a Is Nothing Then
'MsgBox "Do nothing"
Else
'MsgBox "Do something"
c.Interior.Color = vbGreen
End If
Next c
.AutoFilterMode = False
End With
End Sub
I have an Excel-macro that basically works just fine for most of the cases, but there are three issues that bug me.
The code is a bit longer so I've reduced it to address the issues: (The issues are also marked in my code.)
Nr.1: When uniqueArray consists of more than one entry, the Dim for item and uniqueArray are fine. But when I've tested the unlikely case that uniqueArray consists of only one entry, I got the error, that the types don't match. I'm usally not programming stuff in Excel, so I'm not really familiar with the different types in vba. Do I need arrays here or can I just change the Dim?
Nr.2: The code gets slower and slower, the more sheets are added to the workbook by the macro. Is that normal behaviour, or can I speed up my code a bit?
Nr.3: A few years ago I had an issue with a slow macro. Then I found the hint with a forced pause. I've tried it with this macro again, and it improved the speed by a huuuge amount of time. How come a pause speeds up a macro?
Sub Three_Issues()
Dim ColumnLetter As String
Dim cell As Range
Dim sheetCount, TotalRow, TotalCol As Integer
'Dim item, uniqueArray As Variant
Dim item, uniqueArray() As Variant
Dim lastRow As Long
Application.ScreenUpdating = False
'Get unique brands:
With Sheets("Brand")
.Columns(1).EntireColumn.Delete
Sheets("Sales").Columns("R:R").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1"), Unique:=True
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'uniqueArray = .Range("A3:A" & lastRow)
'Update:
If .Range("A3:A" & lastRow).Cells.Count = 1 Then
ReDim uniqueArray(1, 1)
uniqueArray(1, 1) = .Range("A3")
Else
uniqueArray = .Range("A3:A" & lastRow).Value
End With
TotalRow = Sheets("Sales").UsedRange.Rows.Count
TotalCol = Sheets("Sales").UsedRange.Columns.Count
ColumnLetter = Split(Cells(1, TotalCol).Address, "$")(1) 'Num2Char
sheetCount = 0 'Counter for statusbar
For Each item In uniqueArray 'item=Brand
'->Issue 1: Runtimer error 13 Types don't match: This happens if the uniqueArray consists of only one brand.
'Then item is Variant/Empty and uniqueArray is Variant/String
'If uniqueArray consists of more than one brand - which is usually the case - it works fine.
'item=Variant/Empty uniqueArray=e.g. Variant/Variant(1 to 2, 1 to 1)
'Can I change the Dim statement to solve this special case, or do I need arrays maybe?
'Filter sales for each brand:
With Sheets("Sales")
.Range(.Cells(2, 1), .Cells(TotalRow, TotalCol)).AutoFilter Field:=18, Criteria1:=item
End With
With Sheets("Agents")
'Delete old...
.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Clear
'...and get new
Sheets("Sales").Range(Sheets("Sales").Cells(3, 2), Sheets("Sales").Cells(2, 2).End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
.Range("A2").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
'List with all agents
For Each cell In Worksheets("Agents").Range("A2", Worksheets("Agents").Range("A1").End(xlDown))
With Sheets("Report")
.Range("I4") = cell 'Copy agent and update the formulas within the report
'->Issue 2: It takes around 10 seconds to fill 10 sheets with the reports of 10 agents.
'When I reach 70-80 sheets, it slows down to 30 seconds for 10 sheets.
'Is this just because of the number of sheets, or can I speed it up again?
.Range(.PageSetup.PrintArea).Copy
Sheets.Add After:=Sheets("Report")
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value 'Replace all formulas with values
Application.CutCopyMode = False
ActiveSheet.Name = cell
sheetCount = sheetCount + 1
If sheetAnz Mod 10 = 0 Then Application.StatusBar = sheetAnz 'Get statusupdate every 10 sheets
End With
Next
'->Issue 3: I create up to 400 sheets and when I want to continue and do some sorting of the sheets for example it takes a very long time.
'But if I add this break for a second, it works reasonably fine again. Why is that? Does vba needs the break to catch up with itself?
'Since the issue is not the sorting and the other stuff after the pause.
Application.Wait (Now + TimeValue("0:00:01")) 'Code becomes faster after that...
'Continue with other stuff.... sorting sheets and so on
Next
Application.ScreenUpdating = True
End Sub
Any ideas on one of the issues?
You can output a array with 1 value or multiple values using the below UDF. This would benefit from also passing along a worksheet variable so objects can be properly qualified
Call the function from your current macro like so
uniqueArray = MyArr(lastrow)
Public Function MyArr(lastrow As Long) As Variant
If Range("A3:A" & lastrow).Cells.Count = 1 Then
ReDim MyArr(1, 1)
MyArr(1, 1) = Range("A3")
Else
MyArr = Range("A3:A" & lastrow).Value
End If
End Function
Update: Did some research and have the code below now
I've been helped quite a bit by you code gods today, so here's another question about something I've never done in Excel VBA before:
I've got some code that selects values from a master table, creates a smaller temporary table, then sorts the table. That's simple enough, but what I'd really like to do is add these values to a form control List Box. The code I have so far is as follows:
Sub Tester()
Dim dateSel As Variant
Dim sevLev, i, rw As Integer
Dim dRange, keyRange, listRange As Range
Dim listArray() As String
sevLev = 1
dateSel = "12/4/2019"
With Sheets("All_Risk_Report")
.Range("A1").AutoFilter _
field:=2, _
Criteria1:=dateSel
.Range("A1").AutoFilter _
field:=13, _
Criteria1:=sevLev
End With
Sheets("All_Risk_Report").Range("A1:AZ50000").SpecialCells(xlCellTypeVisible).Copy
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "TempTable2"
Sheets("All_Risk_Report").Range("F:F").SpecialCells(xlCellTypeVisible).Copy
Sheets("TempTable2").Cells(1, 1).PasteSpecial
Sheets("All_Risk_Report").Range("C:C").SpecialCells(xlCellTypeVisible).Copy
Sheets("TempTable2").Cells(1, 2).PasteSpecial
Sheets("All_Risk_Report").Range("E:E").SpecialCells(xlCellTypeVisible).Copy
Sheets("TempTable2").Cells(1, 3).PasteSpecial
Sheets("All_Risk_Report").Range("I:I").SpecialCells(xlCellTypeVisible).Copy
Sheets("TempTable2").Cells(1, 4).PasteSpecial
Sheets("All_Risk_Report").ShowAllData
Set dRange = Sheets("TempTable2").Range("A1:D500")
Set keyRange = Sheets("TempTable2").Range("A1:A500")
dRange.Sort key1:=keyRange, Header:=xlYes
Set listRange = Sheets("TempTable2").Range("A1:D500")
With Sheets("Calendar").Shapes.Range(Array("List Box 1"))
.Clear
.ColumnHeads = False
.ColumnCount = listRange.Columns.Count
ReDim MyArray(listRange.Rows.Count, listRange.Columns.Count)
rw = 0
For i = 1 To listRange.Rows.Count
For j = 0 To listRange.Columns.Count
MyArray(rw, j) = listRange.Cells(i, j + 1)
Next
rw = rw + 1
Next
.List = MyArray
.TopIndex = 0
End With
End Sub
I'm not sure exactly how to go about this. I've got the table already created, but I've not used form controls much.
Effectively, this will be a miniature scroll-able window within the sheet itself containing a small subset of data. Please let me know if that makes sense and if you have any advice/suggestions/tips. Thanks!