Related
I am using below code in one workbook as the following:
(1) Match a range on SheetA against a range on SheetB.
(2) If the data found on SheetB, then some values will be inserted on SheetB and Sheet Log.
(3) The matched data (rows) on SheetB will be copied to Sheet Result and Autofit.
(4) The matched data (rows) on SheetB will be cleared. (cut & paste is not applicable).
The count of values on the first range in SheetA is normally 7 or 8 and this macro was as fast as it takes 2 seconds to finish all that steps.
I tried to put 146 values on the first range, but the macro turned to be very slow and it took 35 seconds to finish.
Please, how to speed up and optimize this macro?
Note: there is no problem at all to change match code or copy, paste, autofit and clear code.
Link for the full macro and sheet on the first comment.
Sub Match_Copy()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant
For Each Cell In WorkOrder
Match_A = Application.Match(Cell.value, Auto_Data, 0)
If Not IsError(Match_A) Then
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
If ws.name = "SheetB" Then 'Put Data of Close in Log Sheet
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3).value = _
Array(Application.UserName, Now, Cell)
End If
End If
Next Cell
'----------------------------- Copy, Paste, AutoFit and Clear Code
Dim StatusColumn As Range
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Copy
Dim DestRng As Range
Set DestRng = Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1)
DestRng.PasteSpecial xlPasteValues
DestRng.Rows.AutoFit
If DestRng.Rows.RowHeight < 45 Then DestRng.Rows.RowHeight = 45
End If
Next Cell
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Clear
End If
Next Cell
'-----------------------------
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End sub
Please, check the next adapted code. It uses arrays for faster iteration and for faster results return. Also, setting the row height for each cell consumes Excel resources. I commented some rows but no time now for everything. If something unclear, please do not hesitate to ask for clarifications:
Sub Run_Close()
Dim dStart As Double: dStart = Timer
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'------------------
Dim lastR As Long: lastR = Sheets("SheetA").Cells(Rows.Count, "A").End(xlUp).Row
Dim Auto_Data As Range: Set Auto_Data = Sheets("SheetA").Range("A2:A" & lastR)
Dim Count_Auto_Data As Long: Count_Auto_Data = WorksheetFunction.CountA(Auto_Data)
If Count_Auto_Data = 0 Then Exit Sub
With Auto_Data
.NumberFormat = "General"
.Value = .Value
End With
'------------------
Sheets("Result").AutoFilter.ShowAllData
Dim ws As Worksheet, arrWsFin, arrLog, k As Long
For Each ws In Sheets(Array("SheetB")) 'There are another 3 Sheets
ws.AutoFilter.ShowAllData
Dim LastRow As Long: LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
Dim WorkOrder As Range: Set WorkOrder = ws.Range("A3:A" & LastRow)
Dim arrWO: arrWO = WorkOrder.Value2 'place the range in an array for faster iteration
ReDim arrWsFin(1 To LastRow, 1 To 3) 'redim array to keep the modifications in ws sheet
ReDim arrLog(1 To 3, 1 To LastRow): k = 1 'redim array to keep maximum modif of ws sheet
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant, i As Long
For i = 1 To UBound(arrWO)
Match_A = Application.Match(arrWO(i, 1), Auto_Data, 0)
If Not IsError(Match_A) Then
arrWsFin(i, 1) = "Close": arrWsFin(i, 2) = Now: arrWsFin(i, 3) = ws.name
If ws.name = "SheetB" Then 'Put Data of Close in the array for further return at once
arrLog(1, k) = Application.UserName: arrLog(2, k) = Now: arrLog(3, k) = arrWO(i, 1): k = k + 1
End If
End If
Next i
ws.Range("G2").Resize(UBound(arrWsFin), UBound(arrWsFin, 2)).Value = arrWsFin
If k > 1 Then
ReDim Preserve arrLog(1 To 3, 1 To k - 1)
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(arrLog, 2), UBound(arrLog)).Value = Application.Transpose(arrLog)
End If
'----------------------------- Copy, Paste and AutoFit, Code
Dim StatusColumn As Range, totRng As Range, lastCol As Long, arrSt, arrResult, arrRow, j As Long
lastR = ws.Cells(Rows.Count, "G").End(xlUp).Row
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
arrSt = StatusColumn.Value2 'place the range in an array for faster iteration
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set totRng = ws.Range("A2", ws.Cells(lastR, lastCol)) 'total range to extract the row slice
Dim rngClearCont As Range
ReDim arrResult(1 To lastCol, 1 To lastR): k = 1
For i = 1 To UBound(arrSt)
If arrSt(i, 1) = "Close" Then
arrRow = totRng.Rows(i).Value
'load arrResult array:
For j = 1 To lastCol
arrResult(j, k) = arrRow(1, j)
Next
k = k + 1
If rngClearCont Is Nothing Then
Set rngClearCont = StatusColumn.Cells(i) 'set the range necessary to clear rows at the end
Else
Set rngClearCont = Union(rngClearCont, StatusColumn.Cells(i))
End If
End If
Next i
If k > 1 Then
ReDim Preserve arrResult(1 To lastCol, 1 To k - 1)
With Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(arrResult, 2), _
UBound(arrResult))
.Value = Application.Transpose(arrResult)
.Rows.RowHeight = 45
End With
rngClearCont.EntireRow.ClearContents
End If
'-----------------------------
Next ws
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Time taken: " & Format(Timer - dStart, "0.00s")
End Sub
It should take less than a second...
The root of your issue is that you are making many edits to the worksheet. One of the first ways to speed up VBA code is to reduce the number of times you write data to the sheet.
Rather than writing your data to the sheet every time in a For Each loop, add all of your data to an Array and then write that entire Array to the sheet(s) at once. This way, you don't have to write multiple times for every For Each loop, but only once.
I cannot guarantee that this is the only reason your code is "sub-optimal" but it's a good place to start to improve performance times.
While writing to the sheet does take time, the main problem here is the copy/paste part.
If you, after the row
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
Put something like:
Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 9).value = Array(Cell, , , , , , "Close", Now, ws.name)
And then remove the copy/paste part completely, you should be able to run it almost instantly.
I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
I have 100.000 records/rows with 17 columns. One of these columns needs to be checked to output either a 1 or 0 to the next column. For this I use a loop with the Instr function, but after 10 mins it still isn't outputting anything on my machine and I believe the code is too intensive or slow running it row for row.
Dim rng As Range
Set rng = Range("F:F")
For Each cell In rng
TicketType = cell
If InStr(1, TicketType, "locker", 1) > 0 Then
cell.Offset(0, 1) = 1
Else
cell.Offset(0, 1) = 0
End If
Next
There are only 100 TicketTypes to check however, and based on the names of these TicketTypes it should output a 1 or 0 (match or not). So I was thinking, maybe there is a way to sort the entire table, run through it to see which categories there are, store their vertical ranges, run a check and then output +-10.000 rows at once? I noticed this is instant, so I believe it's really the Instr function that is the bottleneck.
Try this:
Dim rng As Range, f
With ActiveSheet
Set rng = Application.Intersect(.Columns("F"), .UsedRange)
f = "=--NOT(ISERROR(SEARCH(""locker""," & rng(1).Address(False, False) & ")))"
Debug.Print f
rng.Offset(0, 1).Formula = f
rng.Offset(0, 1).Value = rng.Offset(0, 1).Value
End With
Variant array approach
As mentioned by BigBen it's faster than looping through each cell by means of VBA.
Sub VariantArray()
With Sheet1
'~~> Set you relevant range here
Dim lastRow As Long, rng As Range
lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
Set rng = .Range("F1:F" & lastRow)
'~~> create a one based 2-dim datafield array
Dim myArray As Variant
myArray = rng
'~~> check TicketType
Dim i As Long
For i = 1 To UBound(myArray)
myArray(i, 1) = IIf(InStr(1, myArray(i, 1), "locker", 1) > 0, 1, 0)
Next i
'~~> fill target with array values
rng.Offset(0, 1) = myArray
End With
End Sub
you could try filtering:
With Worksheets("actualSheetName") '<-- change "actualSheetName" to your actual sheet name
With .Range("F1", .Cells(.Rows.Count, "F").End(xlUp))
.Offset(, 1).Value = 0
.AutoFilter Field:=1, Criteria1:="*locker*"
.SpecialCells(xlCellTypeVisible).Offset(, 1) = 1
End With
.AutoFilterMode = False
End With
As suggested by BigBen, a far better solution is the usage of a worksheet function, like Find.All() (at least that how I think it's called). If it finds something, it gives a number, else it gives an error. You might turn this into an interesting formula like this:
=IF(IF.ERR(FIND.ALL("locker";A2);0)=0;0;1)
Thank you in advance for your help.
I am trying to build a macro (which in the end will be part of a bigger macro) that will compare two IDs and based on findings will perform another operation.
The code that I have at the moment only copies the values for each row without any consideration of ID in the first column. Here is the code:
Sub movingValues()
'declaring/setting variables
Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
Dim SheetOneRng As Range, SheetTwoRng As Range
Dim cell As Range, i As Integer
Application.Calculation = xlCalculationManual
Set SheetOneWs = ThisWorkbook.Worksheets("SheetOne")
Set SheetTwoWs = ThisWorkbook.Worksheets("SheetTwo")
SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
Set SheetOneRng = SheetOneWs.Range("A2:D13" & SheetOneLastRow)
Set SheetTwoRng = SheetTwoWs.Range("A2:M13" & SheetTwoLastRow)
SheetOneWs.Range("B2:D13").Value = ""
For i = 2 To SheetTwoLastRow
'For Each cell In SheetTwoWs.Range(Cells(i, "B"), Cells(i, "M"))
For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
If cell.Value = "No" Then
SheetOneWs.Cells(cell.Row, "B").Value = SheetTwoWs.Cells(1, cell.Column)
Exit For
End If
SheetOneWs.Cells(cell.Row, "B").Value = "No data"
Next cell
For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
If cell.Value = "Maybe" Then
SheetOneWs.Cells(cell.Row, "C").Value = SheetTwoWs.Cells(1, cell.Column)
Exit For
End If
SheetOneWs.Cells(cell.Row, "C").Value = "No data"
Next cell
For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
If cell.Value = "Yes" Then
SheetOneWs.Cells(cell.Row, "D").Value = SheetTwoWs.Cells(1, cell.Column)
Exit For
End If
SheetOneWs.Cells(cell.Row, "D").Value = "No data"
Next cell
Next i
Application.Calculation = xlCalculationManual
End Sub
My understanding is that I need to place that inside of another loop to match the IDs, so far I've tried:
For i = 2 To SheetOneLastRow
For a = 2 To SheetTwoLastRow
valTwo = Worksheets("SheetTwo").Range("A" & a).Value
If Cells(i, 1) = valTwo Then
'CODE FROM ABOVE'
End if
Next a
Next i
doesn't seem to work the way I intend it too, all your help will be greatly appreciated. The code initially was taken from the answer in here: Issue with copying values based on condition from one sheet to another VBA
Thank you once again for all your answers.
Best Regards,
Sergej
As far as I can tell, this does what you want.
Sub x()
Dim rID As Range, rMonth As Range, rData As Range, rCell As Range, v As Variant
With Worksheets("SheetTwo")
Set rID = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
Set rMonth = .Range("B1:M1")
Set rData = .Range("B2").Resize(rID.Rows.Count, rMonth.Columns.Count)
End With
With Worksheets("SheetOne")
For Each rCell In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
v = Application.Match(rCell.Value, rID, 0)
If IsNumeric(v) Then
rCell.Offset(, 1).Value = rMonth.Cells(Application.Match("No", rData.Rows(v), 0))
rCell.Offset(, 2).Value = rMonth.Cells(Application.Match("Maybe", rData.Rows(v), 0))
rCell.Offset(, 3).Value = rMonth.Cells(Application.Match("Yes", rData.Rows(v), 0))
End If
Next rCell
End With
End Sub
Because I couldn't really bear looking at your horribly inefficient code, I've reworked it here based on the data provided in your previous question.
What this does is it loops over sheet 2 column A. Then for every cell it finds the corresponding ID and stores the row in "Hit".
It then finds three values in the row of the cell, and adds the month linked to every hit to the correct place in an array.
Then it pastes the array in one go to the correct range in sheet 1.
Sub movingValues()
Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
Dim cel As Range, hit As Range
Dim Foundrow As Integer
Dim arr() As Variant
Application.Calculation = xlCalculationManual
Set SheetOneWs = ThisWorkbook.Worksheets("Sheet1")
Set SheetTwoWs = ThisWorkbook.Worksheets("Sheet2")
SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
ReDim arr(1 To SheetOneLastRow - 1, 1 To 3)
For Each cel In SheetTwoWs.Range("A2:A" & SheetTwoLastRow)
Foundrow = SheetOneWs.Range("A1:A" & SheetOneLastRow).Find(cel.Value).Row - 1
If Not Foundrow = 0 Then
Set hit = SheetTwoWs.Rows(cel.Row).Find("No", SearchDirection:=xlNext)
If Not hit Is Nothing Then
arr(Foundrow, 1) = SheetTwoWs.Cells(1, hit.Column).Value
Else
arr(Foundrow, 1) = "No Data"
End If
Set hit = SheetTwoWs.Rows(cel.Row).Find("Maybe", SearchDirection:=xlNext)
If Not hit Is Nothing Then
arr(Foundrow, 2) = SheetTwoWs.Cells(1, hit.Column).Value
Else
arr(Foundrow, 2) = "No Data"
End If
Set hit = SheetTwoWs.Rows(cel.Row).Find("Yes", SearchDirection:=xlNext)
If Not hit Is Nothing Then
arr(Foundrow, 3) = SheetTwoWs.Cells(1, hit.Column).Value
Else
arr(Foundrow, 3) = "No Data"
End If
End If
Next cel
SheetOneWs.Range("B2:D" & SheetOneLastRow) = arr
End Sub
As you can probably see when trying it, reading your values into an array first makes this pretty much instant, since it saves on "expensive" write actions. With the tests in place and this structure it should be much more straightforward and rigid than your previous code. Using Find means it only needs to loop over each row once, further increasing performance.
Please note, it's best to back up your data before trying in case of unexpected results and/or errors.
I am stuck with a problem i cannot get my head around currently.
I have a checklist that has to update automatically when adding lines to my excel worksheet so that the checklist is applied to all rows.
I tried to use a "for loop" to modify the formula but excel returns Error 1004, when starting the string with "=".
No error but no functionality as well:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").FormulaLocal = "Wenn(Oder(AB" & firstRow & "=""x"""
Returns error 1004:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").FormulaLocal = "=Wenn(Oder(AB" & firstRow & "=""x"""
My first solution
Loop FormulaR1C1, or Formula and use nothing but english Function names eg. sum() instead of Summe() and follow english syntax , instead of ;.
Problem
When testing the syntax without a loop and actual indices it works like a charm. As soon as I try to loop it, Excel does not recognize R[i]C as cell anymore but just returns plain text.
no issues:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Formula = "IF(OR( R[1]C = ""x"""
issues:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Formula = "IF(OR( R[i]C = ""x"""
Splitting it like this did not solve my problem either
..R[" & i & "]C =..
Any tips?
// For i= ... to .. next i
// Excel 2007
Try this:
With ActiveWorkbook.Sheets("Kalkulation Änderungen")
'find last row of column AB
LastRow = .Cells(.Rows.Count, "AB").End(xlUp).Row
'apply the formula from AB9 to its last non-blank row
.Range("AB9:AB" & LastRow).Formula = "IF(OR( R[1]C = ""x"""
End With
#UGP: that is what i thought the code might look like after implementing your tips with intersect etc.
What do you think of it, I guess you might not like the loops too much?
Typical beginner approach to loop everything?
I would have to do this for every column accordingly?
If so it would be wise to create a sub () for every column with an exit condition so that i save computing time?
Unless it is possible to hand over the columnadress to the sub_worksheet_change()?
Private Sub Worksheet_Change(ByVal Target As Range, selected_column)
_
_
_
_
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim i As Integer
Dim check As Boolean
frstRow = 1
lastRow = 1
i = 1
'Rowcount
Do Until firstRow <> 1 And lastRow <> 1
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("D" & i) = "Länge" Then
firstRow = i + 2
i = i + 1
End If
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("G" & i) = "Gesamt-h" Then
lastRow = i - 2
End If
i = i + 1
Loop
' check column AB fo "x" and modify header
Set KeyCells = Range("AB" & firstRow, "AI" & lastRow)
check = False
i = firstRow
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Do While i <= lastRow And check = False
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB" & i).Value = "x" Then
check = True
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Value = "x"
ElseIf i = lastRow And check = False Then
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Value = " "
End If
i = i + 1
Loop
End If
End Sub
Here's the code. It has to be in the corresponding worksheet in the VBA-Editor.
It activates when a cell in Range(A10:A20) has been changed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A10:A20")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Target.Count = 1 Then
If Target.Value = "x" Then
'Your Code
'i.e
MsgBox (Target.Address & "has been changed")
End If
Else
MsgBox ("Please No Copy Pasterino")
End If
End If
End Sub
EDIT:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim i As Integer
Dim fRow As Long, lRow As Long
Dim check As Boolean
Dim sht As Worksheet
Dim Cell As Range
Set sht = Worksheets("Tabelle1")
'Rowcount
fRow = 2
lRow = sht.Cells(sht.Rows.Count, "G").End(xlUp).Row
' check column AB fo "x" and modify header
Set KeyCells = Range("AB" & fRow & ":AI" & lRow)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
For Each Cell In Range(Cells(fRow, Target.Column), Cells(lRow, Target.Column))
If Cell.Value = "x" Then
sht.Cells(9, Target.Column).Value = "x"
Exit For
Else
sht.Cells(9, Target.Column).Value = ""
End If
Next
End If
End Sub