Is there a way to replace this loop to find Instr? - excel

I have 'for i = 1 to x' loop to fill columns however it is very slow.
I don't have enough knowledge of vba to know a different way.
Here is my code:
Dim j As Long
j = 6
For i = 4 To EFlast_row
If InStr(ef.Cells(i, ActualTitleColumn).Value, search.Cells(searchboxrow, searchboxcolumn).Value)Then
search.Cells(j, SearchLayerColumn).Value = ef.Cells(i, layercolumn).Value
j = j + 1
End If
Next i
Any help would be much appreciated.
Thank you

This code will put the data from sheets into a range variable. Comparisons using range variables are significantly quicker than using a reference like:
Sheets("Sheet1").Cells(1,1).Value
You will need to update this to reflect the variables you are using.
Function search()
' Put data on sheets into ranges
Dim rangeOne As Range, rangeTwo As Range
Set rangeOne = Sheets("Sheet1").UsedRange
Set rangeTwo = Sheets("Sheet2").UsedRange
' Iterands for rangeOne and rangeTwo respectively
Dim i As Long, j As Long
For i = 2 To rangeOne.Rows.Count
For j = 2 To rangeTwo.Rows.Count
If InStr(rangeOne(i, 1).Value2, rangeTwo(j, 1).Value2) Then
rangeTwo(j, 2).Value2 = rangeOne(i, 2).Value2
End If
Next j
Next i
End Function

Related

Fill cells with values from another sheet using For Loop VBA

I have a set of information in the same column (H27:O27) in one sheet ("P1-FR1") and would like to paste individual values to another sheet (AQ6:AX6) ("Übersicht GESAMT")
I'm trying to use a For loop but the values just copy one after the other (in the same cell) instead of copying one in each cell. This is my code:
Sub CopyValues()
Dim i As Long
Dim j As Long
Dim Wert As Long
For i = 8 To 14
Wert = Sheets("P1-FR1").Cells(27, i)
For j = 43 To 50
Sheets("Übersicht GESAMT").Cells(6, j) = Wert
Next j
Next i
End Sub
You don't need a double For loop in this case at all. A simple .Value copy will work. The code below shows two examples with different ways to accomplish what you want. (TIP: it always helps me to be VERY clear on how I name the variables, it helps to keep track of where all the data is coming and going)
Option Explicit
Sub CopyTheValues()
Dim datenQuelle As Range
Dim datenZiel As Range
Set datenQuelle = ThisWorkbook.Sheets("P1-FR1").Range("H27:O27")
Set datenZiel = ThisWorkbook.Sheets("Übersicht GESAMT").Range("AQ6:AX6")
'--- method 1 - works because the ranges are the same size and shape
datenZiel.Value = datenQuelle.Value
'--- method 2 - for loops
' index starts at 1 because the Range is defined above
' (and we don't care what rows/columns are used)
Dim j As Long
For j = 1 To datenQuelle.Columns.Count
datenZiel.Cells(1, j).Value = datenQuelle.Cells(1, j).Value
Next i
End Sub
Copying By Assignment
Option Explicit
Sub CopyValuesNoLoop()
ThisWorkbook.Worksheets("Übersicht GESAMT").Range("AQ6:AX6").Value _
= ThisWorkbook.Worksheets("P1-FR1").Range("H27:O27").Value
End Sub
Sub CopyValuesQuickFix()
Dim j As Long: j = 43
Dim i As Long
For i = 8 To 14
ThisWorkbook.Worksheets("Übersicht GESAMT").Cells(6, j).Value _
= ThisWorkbook.Worksheets("P1-FR1").Cells(27, i).Value
j = j + 1
Next i
End Sub
The nesting of the for loops is causing your issue. It is causing each cell from the first sheet to be copied to all cells on the second sheet.
You only need one loop to perform the copy. Something like this should work.
Sub CopyValues()
Dim i As Long
For i = 8 To 15
Sheets("Übersicht GESAMT").Cells(6,i+35) = Sheets("P1-FR1").Cells(27,i)
Next i
End Sub

Select range equal to variables in array using loop

I wrote a program using VBA which shown below. there was an array(ary) which contain(C,F,B,PC,PB). I create the loop to go through each variable in the array.
what I want to do with my code is I have a datasheet that includes that array values as categories. I want to assign each array values to p range. then execute data from the p range. then want to assign p to next array value and do the same.
but the problem is range p is firstly set ary(1)="C" and give the correct result. but after it becomes equal to "F" didn't work properly. it contains the same range previously gave. can anyone help me with this problem?
For i = 1 To UBound(ary)
cat = ary(i)
Set p = Nothing
Set c = Nothing
For Each c In Range("E:E")
If c.Value = cat Then
If p Is Nothing Then
Set p = c.Offset
Else
Set p = Union(p, c)
End If
End If
Next c
'get values
p.Offset(, -1).Copy Destination:=ws.Range("N" & Rows.Count).End(xlUp).Offset(1)
next i
The key error in your code is the idea that you might collect a range of non-consecutive cells and paste their value into a contiguous range. Excel can't do that. My code below collects qualifying values into an array and pastes that array into the target range.
The code below can't be exactly what you want because you didn't provide some vital information. However, please try it anyway with the aim of adapting it to your project.
Private Sub Review()
Dim Ws As Worksheet
Dim Rng As Range
Dim Rl As Long ' last row in column E
Dim Ary() As String
Dim Arr As Variant
Dim n As Long
Dim Cell As Range
Dim i As Long
Set Ws = Worksheets("Sheet1")
Ary = Split("C,F,B,PC,PB", ",") ' this array would be 0-based
Rl = Cells(Rows.Count, "E").End(xlUp).Row ' Range("E:E") has 1.4 million cells
Set Rng = Range(Cells(2, "E"), Cells(Rl, "E"))
For i = 0 To UBound(Ary)
ReDim Arr(1 To Rl)
n = 0
For Each Cell In Rng
If Cell.Value = Ary(i) Then
n = n + 1
Arr(n) = Cell.Offset(0, 1).Value
End If
Next Cell
If n Then
ReDim Preserve Arr(n)
'get values
Ws.Cells(Ws.Rows.Count, "N").End(xlUp).Offset(1) _
.Resize(UBound(Arr)).Value = Arr ' Application.Transpose(Arr)
End If
Next i
End Sub
This code works entirely on the ActiveSheet and then pastes the result to another sheet, named as "Sheet1". That isn't good practice. The better way would be to declare variables for both sheets and let the code refer to the variables so as to ensure that it has full control of which sheet it's working on at all times.
Set p = Union(p, c) will never be executed because it will only occur if p is NOT nothing, and Set p = Nothing is executed each time the outer loop iterates.

Split data string over columns AND rows using VBA

I am trying to speed up a currently working automated workbook.
PHP sends a string similar to the below to VBA:
1[|:#:|]text-one[|:#:|]code-one[|:#:|]qty-one[{:#:}]
2[|:#:|]text-two[|:#:|]code-two[|:#:|]qty-two[{:#:}]
where
[|:#|] represents "new column"
[{:#:}] represents "new row"
When it is parsed by the VBA this is the output:
I currently use the following VBA code to parse this into a workbook:
myArray = Split(myReply, "[{:#:}]")
myRow = 1
For Each element In myArray
myRow = myRow + 1
subArray = Split(element, "[|:#:|]")
myCol = 2
For Each subelement In subArray
myCol = myCol + 1
Cells(myRow, myCol).Value = subelement
Next subelement
Next element
I am about to start optimising the code in this workbook and I am aware I can do something like (pseudo code):
for each element....
Range("C2:F2").Value = Split(element, "[|:#:|]") 'Example row number would be incremental
However is there a way to do it so that I can split into the entire Range?
For example, If I know there are 29 "rows" within the data that has been returned, I would like to be able to use split to place the data into all the rows.
I imagine the syntax would be something similar to the below, however this doesn't seem to work:
Range("C2:F29").Value = Split(Split(element, "[|:#:|]"),"[{:#:}]")
The optimal thing to do is to do everything in native VBA code and not interact with the Excel sheet until the end. Writing to sheet is a time consuming operation, so this procedure does it once and once only, writing the whole two-dimensional array at once, rather than writing it line by line. Therefore no need to disable screen updating, calculation, or anything else.
Function phpStringTo2DArray(ByVal phpString As String) As Variant
Dim iRow As Long
Dim iCol As Long
Dim nCol As Long
Dim nRow As Long
Dim nColMax As Long
Dim lines() As String
Dim splitLines() As Variant
Dim elements() As String
lines = Split(phpString, "[{:#:}]")
nRow = UBound(lines) - LBound(lines) + 1
ReDim splitLines(1 To nRow)
For iRow = 1 To nRow
splitLines(iRow) = Split(lines(iRow - 1), "[|:#:|]")
nCol = UBound(splitLines(iRow)) - LBound(splitLines(iRow)) + 1
' in case rows have different number of columns:
If nCol > nColMax Then nColMax = nCol
Next iRow
Erase lines
'We now have a (Variant) array of arrays. Convert this to a regular 2D array.
ReDim elements(1 To nRow, 1 To nColMax)
For iRow = 1 To nRow
nCol = UBound(splitLines(iRow)) - LBound(splitLines(iRow)) + 1
For iCol = 1 To nCol
elements(iRow, iCol) = splitLines(iRow)(iCol - 1)
Next iCol
Next iRow
Erase splitLines
phpStringTo2DArray = elements
End Function
Example usage:
Dim s As String
Dim v As Variant
s = "1[|:#:|]text-one[|:#:|]code-one[|:#:|]qty-one[{:#:}]2[|:#:|]text-two[|:#:|]code-two[|:#:|]qty-two[{:#:}]"
v = phpStringTo2DArray(s)
'Write to sheet
Range("A1").Resize(UBound(v, 1), UBound(v, 2)) = v
If you want to ignore the final line break [{:#:}], could add this line at the top of the function:
If Right(phpString, 7) = "[{:#:}]" Then phpString = Left(phpString, Len(phpString) - 7)
This wasn't as easy as I originally thought. I can get rid of one loop easily. But there's still an if test, so it doesn't break on empty strings etc. I feel a guru could make this even more efficient.
My worry is that for you this process is taking a lot of time. If you are trying to speed things up, your code doesn't look too horribly inefficient.
More likely if it's running slowly, is that the application.calculation & application.screenUpdating settings are set incorrectly.
Sub takePHP(myString As String)
'This sub takes specially formatted strings from a PHP script,
'and parses into rows and columns
Dim myRows As Variant
Dim myCols As Variant
Dim subRow As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculateManual
myRows = Split(myString, "[{:#:}]")
x = 1
For Each subRow In myRows
bob = Split(subRow, "[|:#:|]")
If UBound(bob) <> -1 Then
Range(Cells(x, 1), Cells(x, UBound(bob) + 1)).Value = bob
x = x + 1
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Copy single row range to array then pass ByRef to function VBA

I've been struggling with this code here (probably very simple mistake), would anyone mind pointing out where my issues are? My overall goal is to allow this subroutine to accept a range of variable size, however I can't seem to get it to work for a fixed size.
If I manually allocate the array, things work as expected but when I allocate with a range that's where things go wrong. The output comes back untouched, which leads me to believe that I'm not doing something correctly with the allocation. Also I'm getting errors when I try to pass ws.UsedRange as oppose to a fixed range.
Private Sub InsertionSort(ByRef a(), ByVal lo0 As Long, ByVal hi0 As Long)
Dim i As Long, j As Long, v As Long
For i = lo0 + 1 To hi0
v = a(i)
j = i
Do While j > lo0
If Not a(j - 1) > v Then Exit Do
a(j) = a(j - 1)
j = j - 1
Loop
a(j) = v
Next i
End Sub
Sub runSort()
Dim ws As Worksheet
Set ws = ActiveWorkbook.ActiveSheet
Dim myArr() As Variant
Dim rangeUse As Range
With ws.Range("D17:K17")
ReDim myArr(1 To 1, 1 To ws.Range("D17:K17").Columns.Count)
myArr = ws.Range("D17:K17").Value
End With
Call InsertionSort(myArr, LBound(myArr), UBound(myArr))
Range("D19:K19") = myArr
End Sub
Any help would be appreciated! TIA
So considerating you only want to sort your 2-dimensional array row by row, this might be a useful starting point. You can always change With ws.Range("A2:A3") to With Selection. If you do so, you have the Range you selected with your cursor.
With ws.Range("A2:A3")
myArr = .Value
For i = 1 To .Rows.Count
ReDim tmpArr(1 To .Columns.Count)
For j = 1 To .Columns.Count
tmpArr(j) = myArr(i, j)
Next j
Call InsertionSort(tmpArr, 1, .Columns.Count)
For j = 1 To .Columns.Count
myArr(i, j) = tmpArr(j)
Next j
Next i
.Offset(RowOffset:=10) = myArr
End With
Detailed Description
You don't have to redim myArray because if you set it to a range, it automatically scales.
tmpArr is each row of your range. If you select your range with the cursor some rows might be shorter or longer than others, thats why we redim that one. Edit This doesn't work just yet, because .Columns.Count refers to the whole range, not just the row. If you have different column counts then you'd have to change that.
For j = 1 To .Columns.Count
tmpArr(j) = myArr(i, j)
Next j
Unfortunately we cannot use tmpArr = myArr(i) because only one dimension of a multidimensional array cannot be accessed like this in VBA.
Call InsertionSort(tmpArr, 1, .Columns.Count) calles your Insertion Sort algorithm and sorts one row at a time.
After tmpArray got sorted, we have to set myArray(i) to the new values with the same loop we already used:
For j = 1 To .Columns.Count
myArr(i, j) = tmpArr(j)
Next j
Now we sorted all the rows in our Range, now we can put it back on the sheet, 10 rows beneath the first row of the specified range with .Offset(RowOffset:=10) = myArr
I hope that this helps you! While testing I saw that you might have a little bug in your InsertionSort algorithm. If the first value is the smalles, it just blindly gets copied into all the other fields of the array :)

Faster way to Find and Copy Values

Hello, I am doing a macro that copy the values on the columns, VALUES1, VALUES2, VALUES3 if it is not blank when the ARTICLE is the same.
I would have the first spreadsheet and I want the macro to return the second Spreadsheet.
I have managed how to make it:
Sub test()
Dim i, last, j, x As Integer
Dim R As Range
last = Sheets("List2").Range("A100000").End(xlUp).Row - 2
For i = 0 To last
Set R = Sheets("List2").Range("A2")
If Not WorksheetFunction.CountIf(Sheets("List2").Columns(1), _
Sheets("List2").Range("A2").Offset(i, 0).Value) = 0 Then
For j = 1 To WorksheetFunction.CountIf(Sheets("List2").Columns(1), _
Sheets("List2").Range("A2").Offset(i, 0).Value)
Set R = Sheets("List2").Columns(1).Find(Sheets("List2").Range("A2"). _
Offset(i, 0).Value, R, LookAt:=xlWhole)
For x = 0 To 2
If Not Sheets("List2").Range("B2").Offset(i, x).Value = "" Then
R.Offset(0, "1" + x).Value = Sheets("List2"). _
Range("B2").Offset(i, x).Value
End If
Next x
Next j
End If
Next i
End Sub
but the problem it takes too long, 'cause I have around 10.000 Rows and 20 Columns, and besides the Spreadsheet is not in order, so it could be to has a disorder, something like (A, B, B, A, ...)
Is there any way to make it faster o better???
Thanks a lot. Themolestones.
Here is a very easy solution with formulas to your problem:
Sheet2!A1=Sheet1!A1
Sheet2!B1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!B:B)
Sheet2!C1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!C:C)
Sheet2!D1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!D:D)
Put these formulas in the cells left of the = and copy down. You really need only the first two, because you can copy the second also to the right.
You need Sheet1 to be sorted by article.
That's it.
Of course, there might be occasions, when it is just necessary to implement this with VBA. Usually the fastest way to handle large amounts of cells with VBA, is to use array-copies of your ranges. Using worksheet-functions and looping through single cell references slows you down heavily.
Edit:
This would be my VBA solution
Public Sub Demo()
Dim arrRange() As Variant
Dim arrRangeResult() As Variant
Dim i As Long
Dim j As Long
Dim copyVal As Variant
Dim copyCond As Variant
Dim copyCol As Long
'create two copies of the origin data
arrRange = Range("A:D")
arrRangeResult = Range("A:D")
'loop through first data-copy, downwards through the articles
For i = LBound(arrRange, 1) + 1 To UBound(arrRange, 1)
'stop loop, if no article was found
If arrRange(i, 1) = "" Then Exit For
'store current article ID
copyCond = arrRange(i, 1)
'loop sideways through value-columns
For j = LBound(arrRange, 2) + 1 To UBound(arrRange, 2)
'store value & column, when found
If arrRange(i, j) <> "" Then
copyVal = arrRange(i, j)
copyCol = j
Exit For
End If
Next j
'loop through output array and paste value
For j = LBound(arrRangeResult, 1) + 1 To UBound(arrRangeResult, 1)
If arrRangeResult(j, 1) = copyCond Then
'paste-down found value to all occurences of article
arrRangeResult(j, copyCol) = copyVal
ElseIf arrRangeResult(j, 1) = "" Then
'early stop, when no article ID is found
Exit For
End If
Next j
Next i
'create output
Range("K:N") = arrRangeResult
End Sub

Resources