I have a small VBA Loop but it takes over 2-3 minute to finish, any idea how I can speed up/rewrite it that it will be faster?
The Range "Replace Names" is a List of 500 names of named areas in "Data".
The for loop searches for the one that matches the name in "Data" and replaces the one with the name from "Source". This also works fine, but it takes a while. Is there a faster method?
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For Each ID_name In wsSupport.Range("ReplaceNames")
wsCheck.Range("Data").Replace ID_name, wsSource.Range(ID_name), xlWhole
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
You might benefit from this valuable piece of text:
https://www.microsoft.com/en-us/microsoft-365/blog/2009/03/12/excel-vba-performance-coding-best-practices/
So in your case the Code could somewhat look like this:
Dim arrData as Variant, arrSource as Variant, k as long
arrData = wsCheck.Range("Data").value2 'this creates a two-dimensional array with rows on the first and columns on the second index
arrSource = wsSource.Range(...).value2
'loop through rows I suppose
for k = LBound(arrData,1) to UBound(arrData,1)
if arrData(k, yourColumn) = ... then
arrData(k, yourColumn) = arrSource(rowhere, columnhere)
endif
next k
wscheck.range("Data") = arrData
Its working now!!!
If you see mistakes let me know!
Dim arrData As Variant, arrSource As Variant, arrNames As Variant, k As Long
arrData = wsChecklist.Range("Checklist").Value2 'this creates a two-dimensional array with rows on the first and columns on the second index
arrSource = wsSupport.Range("ReplaceNames").Value2
arrNames = wsNia.Range("D1:D1000").Value2
'loop through rows I suppose
For k = LBound(arrData, 1) To UBound(arrData, 1)
For j = LBound(arrData, 2) To UBound(arrData, 2)
' If UCase(arrData(k, j)) = UCase(arrSource(x, 1)) Then
If UCase(arrSource(x, 1)) = UCase(arrData(k, j)) Then
For i = 1 To 1000
Name1 = wsNia.Cells(i, 2)
Name2 = wsNia.Cells(i, 3)
Name = Name1 & "_" & Name2
If UCase(arrData(k, j)) = UCase(Name) Then
arrData(k, j) = arrNames(i, 1)
x = x + 1
k = 1
j = 1
i = 1
Exit For
End If
Next i
End If
If k > 2900 And x < 265 Then
x = x + 1
j = 1
k = 1
End If
Next j
Next k
wsChecklist.Range("Checklist").Value2 = arrData
Related
I'm actually facing a problem today. I'm trying to find a row in an Excel Table and return it, based on an entire array of values supposed to match the table
There's a table exemple, they always start with an ID Column that is missing from my Array.
This listbox are the data that I'm getting in my array.
I'm actually using a function that search for a perfect match of my array into a specified table. But I need to make it start on second columns of table.
Here's my function.
Function checkDuplicate(ws As Worksheet, valuesArray As Variant) As Boolean
Dim i As Long, n As Long, j As Long, z As Long
Dim ar
If ws.Name = "Interface" Or ws.Name = "Listes" Then Exit Function
z = LBound(valuesArray)
n = UBound(valuesArray) - z + 1
With ws
ar = .UsedRange.Columns(1).Resize(, n)
For i = 1 To UBound(ar)
j = 1
Do
If ar(i, j) <> valuesArray(j + z - 1) Then
Exit Do
End If
j = j + 1
Loop While j <= n
If j > n Then
checkDuplicate = True
Exit Function
End If
Next
End With
End Function
Any help would be higlhy appreciated, Thank.
This worked for me:
Sub Tester()
Debug.Print checkDuplicate(ActiveSheet, Array("A", "B", "C", "D"))
End Sub
Function checkDuplicate(ws As Worksheet, valuesArray As Variant) As Boolean
Dim i As Long, n As Long, j As Long, z As Long
Dim ar, col As Long, sz As Long
If ws.Name = "Interface" Or ws.Name = "Listes" Then Exit Function
sz = UBound(valuesArray) - LBound(valuesArray) + 1 'size of valuesArray
'pick up data starting with second column
ar = ws.UsedRange.Columns(2).Resize(, sz).Value
For i = 1 To UBound(ar, 1)
checkDuplicate = False
col = 1
For j = LBound(valuesArray) To UBound(valuesArray)
checkDuplicate = ar(i, col) = valuesArray(j) 'match
If Not checkDuplicate Then Exit For 'no match: stop checking
col = col + 1 'next column in sheet array
Next j
If checkDuplicate Then Exit Function 'all columns matched - done searching
Next i
End Function
let me explain my problem:
I have two excel sheets "data" and "output". In the first column of each sheet there are numbers that need to be compared. The numbers look like: 3081671
If I find a number in sheet output that matches the current iteration in the sheet data, I want that the value in the same line in sheet data is written right next to the number in sheet output. This actually works.
However, some of the numbers in sheet data look like this: V3081671A
When iterating and finding such a number in sheet data, I cut the V and A such that only the integer is left.
However, for those cases the if statement "If test = comp Then..." is false, even though test and comp should contain exactly the same strings. Why is this the case?
Any help to solve the problem is really appreciated. If I didn't describe it clear enough, feel free to ask.
Sub MatchNumbers()
Dim i As Integer
Dim j As Integer
Dim buffer As Variant
Dim comp As Variant
Dim test As Variant
Dim inp As Variant
j = 2
While IsEmpty(ActiveSheet.Cells(j, 1)) = False
ActiveSheet.Cells(j, 2) = "NV"
j = j + 1
Wend
i = 2
inp = Tabelle1.Cells(i, 1)
While IsEmpty(inp) = False
If Not IsNumeric(Left(inp, 1)) And Len(inp) >= 9 Then
comp = Mid(inp, Len(inp) - 7, 7)
Else
comp = inp
End If
j = 2
test = ActiveSheet.Cells(j, 1)
Do While IsEmpty(test) = False
If Left(inp, 1) = "V" Then
MsgBox ("Neue Zeile!")
ActiveSheet.Cells(j, 1).EntireRow.Insert Shift:=xlDown
j = j + 1
ActiveSheet.Cells(j, 1) = inp
End If
ActiveSheet.Cells(j, 2) = Tabelle1.Cells(i, 3)
Exit Do
End If
j = j + 1
test = ActiveSheet.Cells(j, 1)
Loop
i = i + 1
inp = Tabelle1.Cells(i, 1)
Wend
End Sub
I have two lists of Data. List A and B both contain letter grades. I want to compare the data and if both lists have the same letter, I want to move that letter to list C that is blank to start with. If the two lists do not have the same letter, keep the letter where it is. I want to use 2 arrays to store the data and then create three new arrays for new list a,b, and c. Here is what I have so far.
Sub example1()
Dim ListA As Range, ListB As Range, ListC As Range
Range("H4:H10").Name = "ListA"
Range("I4:I6").Name = "ListB"
Range("J4", Range("J4").End(xlDown)).Name = "ListC"
Dim A(1 To 7), B(1 To 3), i As Integer, j As Integer
For i = 1 To 7 'stores data in listA in array A
A(i) = Range("ListA").Cells(i)
Next
For j = 1 To 3 'stores data in listB in array B
B(j) = Range("ListB").Cells(j)
Next
'select first from ListA and then compare data to listB
' if it is not found, stop and go to next item
'if it IS found, put in list C
Dim isfound As Boolean, letter As Variant, C(1 To 7), k As Integer
For i = 1 To 7
isfound = False
For j = 1 To 3
If A(i) = B(j) Then
isfound = True
letter = A(i)
Exit For
End If
Next
For k = 1 To 7
C(k) = Range("ListC").Cells(k) 'this is the part I am stuck on. How
do I get data to paste over to List C?
If isfound = True Then
C(k) = A(i) 'this says it will be equal to A(i) value if it is
found.
End If
Next
Next
End Sub
Something like this would work:
Sub example1()
Dim ListA, ListB, ListC(), i As Long, n As Long, m
ListA = Range("H4:H10").Value
ListB = Range("I4:I8").Value
ReDim ListC(1 To UBound(ListA, 1), 1 To 1) 'size the "dups" array
n = 1
For i = 1 To UBound(ListA, 1)
m = Application.Match(ListA(i, 1), ListB, 0) '<< check for match
If Not IsError(m) Then '<< have a duplicate
ListC(n, 1) = ListA(i, 1) 'add to ListC
ListA(i, 1) = "" '(optional) remove from original lists...
ListB(m, 1) = ""
n = n + 1
End If
Next i
'print to sheet...
Range("K4").Resize(UBound(ListA, 1)).Value = Compact(ListA)
Range("L4").Resize(UBound(ListB, 1)).Value = Compact(ListB)
Range("M4").Resize(UBound(ListC, 1)).Value = Compact(ListC)
End Sub
'remove empty array locations...
Function Compact(arr)
Dim rv(), p As Long, i As Long
ReDim rv(1 To UBound(arr, 1), 1 To 1)
For i = 1 To UBound(arr, 1)
If Len(arr(i, 1)) > 0 Then
p = p + 1
rv(p, 1) = arr(i, 1)
End If
Next i
Compact = rv
End Function
This assumes listA/B each contains unique values (no repeats within one list)
Since i find my problem hard to explain, I'll just provide an example.
This is the format of the data i have in excel in a column, separated by blanks.
A
B
C
D
E
F
G
H
I wish to transpose it so that the final result is:
A B F
C G
D H
E
How do I do that?
Here is Honorez's method:
Sub Honorez()
Dim N As Long, i As Long, j As Long, k As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 2
k = 0
For i = 1 To N
v = Cells(i, 1)
If v = "" Then
j = j + 1
k = 0
Else
k = k + 1
Cells(k, j) = v
End If
Next i
End Sub
Array method
In addition to #Gary's-Student 's fine solution, I demonstrate another approach using a datafield Array and write back values directly to the new columns:
Sub Honorez2()
Dim rng As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Honorez")
Dim i As Long, ii As Long, j As Long, m As Long, n As Long
Dim a()
' get data
n = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range("A1:A" & n)
rng.Offset(0, 1).Resize(n, n - WorksheetFunction.CountA(Range("A:A")) + 1) = "" ' clear prior values
' write data field to array
a = rng
j = 2 ' start column for results
For i = 1 To n
If a(i, 1) = "" Or i = n Then
' write data to new column
ws.Range(ws.Cells(1, j), ws.Cells(i - ii, j)).Value = _
ws.Range(ws.Cells(ii + 1, 1), ws.Cells(i, 1)).Value
' remember row and increment column counter
ii = i: j = j + 1
End If
Next i
End Sub
Column A contains the labels or outcome value, Columns B-N contain varying lengths of comma separated values, but range for each column is the same (i.e., 1-64). The goal is to covert to a new table with Column A representing the value range (1-64) and Columns B-N the labels/outcome from the original table.
A semi-related solution was sought here, but without use of macros.
I will let you to modify this code,
Sub splitThem()
Dim i As Long, j As Long, k As Long, x As Long
x = 1
Sheets.Add.Name = "newsheet"
For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(i, j) <> "" Then
For k = 1 To Len(Cells(i, j)) - Len(Replace(Cells(i, j), ",", "")) + 1
Sheets("newsheet").Cells(x, j) = Cells(i, 1)
x = x + 1
Next k
End If
Next i
x = 1
Next j
End Sub
Try this code.
Sub test()
Dim vDB, vR()
Dim vSplit, v As Variant
Dim Ws As Worksheet
Dim i As Long, n As Long, j As Integer, c As Integer
vDB = Range("a2").CurrentRegion
n = UBound(vDB, 1)
c = UBound(vDB, 2)
ReDim vR(1 To 64, 1 To c)
For i = 1 To 64
vR(i, 1) = i
Next i
For i = 2 To n
For j = 2 To c
vSplit = Split(vDB(i, j), ",")
For Each v In vSplit
vR(v, j) = vDB(i, 1)
Next v
Next j
Next i
Set Ws = Sheets.Add '<~~ replace your sheet : Sheets(2)
With Ws
For i = 1 To c
.Range("b1")(1, i) = "COND" & i
Next i
.Range("a2").Resize(64, c) = vR
End With
End Sub