With following to this question Link
, I need to match the values found in wb1.coumns(1) with the other workbook wb2.coumns(1) with some particular conditions.
Wb2 will be filtered with the value Close at column 13 M.
My question: is to seek the Wb2 (the open workbook) Latest closing Date on column 11 K and then copy the respective values at columns (“B, and “Q:X”) (on the same row ),
Then paste these values in Wb1.columns (“S:AA”) respectively.
The below code designed to returns back with the respective values of only one column of wb2 (column “B”)
This is the Link for test workbooks.
Option Explicit
Option Compare Text
Sub Get_Respective_Values_Of_Last_Closing_Date()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim arr1() As Variant, arr2() As Variant
Dim dict As New Dictionary
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open(ThisWorkbook.path & "\Book_B.xlsb", UpdateLinks:=False, ReadOnly:=True)
Set ws1 = wb1.Sheets(1)
Set ws2 = wb2.Sheets(1)
Set rng1 = ws1.Range("A3:AA" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row) 'Main Range
Set rng2 = ws2.Range("A3:X" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row) 'Opened Workbook_Range
arr1 = rng1.Value2
arr2 = rng2.Value2
'place the unique last key in a dictionary:
Dim i As Long
For i = 1 To UBound(arr2)
If arr2(i, 13) = "Close" Then 'Column (Status)
If Not dict.Exists(arr2(i, 1)) Then
dict(arr2(i, 1)) = Array(arr2(i, 2), arr2(i, 11)) 'Place the _Date_ from K:K, too
Else
If CDate(arr2(i, 11)) > CDate(dict(arr2(i, 1))(1)) Then 'Change the item only in case of a more recent _Date_:
dict(arr2(i, 1)) = Array(arr2(i, 2), arr2(i, 11))
End If
End If
End If
Next i
'Place the necessary data in its place:
For i = 1 To UBound(arr1)
If dict.Exists(arr1(i, 1)) Then
arr1(i, 19) = dict(arr1(i, 1))(0) 'extract first item array element
Else
arr1(i, 19) = "NA"
End If
Next i
rng1.Value2 = arr1 'drop back the updated array content
ws1.Activate
' wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Please, test the next updated code:
Sub Get_Respective_Values_Of_Last_Closing_Date()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim arr1() As Variant, arr2() As Variant
Dim dict As New Dictionary
'Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open(ThisWorkbook.path & "\Book_B.xlsb", UpdateLinks:=False, ReadOnly:=True)
Set ws1 = wb1.Sheets(1)
Set ws2 = wb2.Sheets(1)
Set rng1 = ws1.Range("A3:AA" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row) 'Main Range
Set rng2 = ws2.Range("A3:X" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row) 'Opened Workbook_Range
arr1 = rng1.Value2
arr2 = rng2.Value2
'place the unique last key in a dictionary:
Dim i As Long, arrAtt, j As Long, k As Long
ReDim arrAtt(7) 'the 1D array should contain maximum number of elements from "Q" to "X"
'meaning 8 columns. since arrAtt is 1D zero based, it may keep 8 elements
For i = 1 To UBound(arr2)
If arr2(i, 13) = "Close" Then 'Column (Status)
Erase arrAtt: ReDim arrAtt(7) 'erase the previous loaded array, if the case (to be loaded...)
If Not dict.Exists(arr2(i, 1)) Then
For j = 0 To UBound(arrAtt) 'iterate between the 8 array elements
If arr2(i, 17 + j) <> "" Then
arrAtt(k) = arr2(i, 17 + k): k = k + 1 'add the found URLs and increment k
Else
Exit For 'exit the iteration if no URL exists
End If
Next j
If k > 0 Then ReDim Preserve arrAtt(k - 1) 'keep only the loaded elements
dict(arr2(i, 1)) = Array(arr2(i, 2), arr2(i, 11), arrAtt) 'Place attachments array, too
k = 0 'reinitialize k variable
Else
If CDate(arr2(i, 11)) > CDate(dict(arr2(i, 1))(1)) Then 'Change the item only in case of a more recent Date
Erase arrAtt: ReDim arrAtt(7) 'erase the previous loaded array
For j = 0 To UBound(arrAtt)
If arr2(i, 17 + j) <> "" Then
arrAtt(k) = arr2(i, 17 + k): k = k + 1
Else
Exit For
End If
Next j
If k > 0 Then ReDim Preserve arrAtt(k - 1)
dict(arr2(i, 1)) = Array(arr2(i, 2), arr2(i, 11), arrAtt) 'Place attachments array, too
k = 0
End If
End If
End If
Next i
'Place the necessary data in its place:
For i = 1 To UBound(arr1)
If dict.Exists(arr1(i, 1)) Then
arr1(i, 19) = dict(arr1(i, 1))(0) 'extract first item array element
For j = 0 To UBound(dict(arr1(i, 1))(2)) 'extract existing URLs
If dict(arr1(i, 1))(2)(j) = "" Then Exit For 'exit the loop in case of empty strings
arr1(i, 20 + j) = dict(arr1(i, 1))(2)(j) 'place the URLs in their position
Next j
Else
arr1(i, 19) = "NA"
End If
Next i
rng1.Value2 = arr1 'drop back the updated array content
ws1.Activate
' wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
But, if you intend to adapt wb2 workbook in terms of clearing some URLs (for the latest closing Date) , the code should be adapted to preliminarily clear the range "S:AA" in wb1 till the end of the sheet. Otherwise, existing URLs may remain from the previous run
Related
I am looking for if it is possible to get the data and headers from a table as in the example image and have the output go to two columns with the first column being a repeating header? I did try the transpose however the email row kept populating up to column E.
Please, try the next way. It uses arrays being fast even for large ranges, mostly working in memory. It returns starting from "F2". It is able to process any other columns you (may) need, after "Status":
Sub TransposeMails()
Dim sh As Worksheet, lastR As Long, lastCol As Long
Dim arrH, arr, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet 'use here the necessary sheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column 'last column
arrH = Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2) 'place headers in an array
arr = sh.Range("A2", sh.cells(lastR, lastCol)).Value2 'place the range to be processed (except headers) in an array for faster iteration/processing
ReDim arrFin(1 To (UBound(arrH) + 1) * UBound(arr), 1 To 2) 'Redim the final array (keeping the processed result)
'+ 1 for the empty rows in between...
For i = 1 To UBound(arr)
For j = 1 To UBound(arrH)
k = k + 1
arrFin(k, 1) = arrH(j, 1): arrFin(k, 2) = arr(i, j)
Next j
k = k + 1 'for the empty row between groups...
Next i
'drop the processed array content:
sh.Range("G2").Resize(UBound(arrFin), 2).Value2 = arrFin
End Sub
The code can be easily adapted to return anywhere (another sheet, workbook, range etc).
The range to be processed must start from "A1" ("Email" header) and not having any other record after the last header (on the first row)...
Transpose Data
Sub TransposeData()
Const SRC_NAME As String = "Sheet1"
Const DST_NAME As String = "Sheet1"
Const DST_FIRST_CELL As String = "A8"
Const EMPTY_COLS As Long = 0
Const EMPTY_ROWS As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim drOffset As Long: drOffset = srg.Columns.Count + EMPTY_ROWS
Dim dcOffset As Long: dcOffset = 1 + EMPTY_COLS
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Application.ScreenUpdating = False
Dim srrg As Range, shrg As Range
Dim IsHeaderReady As Boolean, IsFirstRowDone As Boolean
For Each srrg In srg.Rows
If Not IsHeaderReady Then
srrg.Copy
dfCell.PasteSpecial Transpose:=True
Set shrg = dfCell.Resize(srg.Columns.Count) ' transpose no more
IsHeaderReady = True
Else ' header is ready; it's already copied for the first data row
If IsFirstRowDone Then shrg.Copy dfCell Else IsFirstRowDone = True
srrg.Copy
dfCell.Offset(, dcOffset).PasteSpecial Transpose:=True
Set dfCell = dfCell.Offset(drOffset)
End If
Next srrg
Application.ScreenUpdating = True
MsgBox "Data transposed.", vbInformation
End Sub
If I understand you correctly
Sub test()
'set the range of the header as rg variable
'count how many data under EMAIL header as cnt variable
Dim rg As Range: Set rg = Range("A1", Range("A1").End(xlToRight))
Dim cnt As Integer: cnt = Range(rg, rg.End(xlDown)).Rows.Count - 1
Dim i As Integer: Dim rslt As Range
'loop to each range with data as many as the cnt value
'prepare the result range as rslt variable
'put the value of header name to rslt range
'put the looped range value to rslt.offset(0,1)
For i = 1 To cnt
Set rslt = Range("A" & Rows.Count).End(xlUp).Offset(3, 0) _
.Resize(rg.Columns.Count, 1)
rslt.Value = Application.Transpose(rg)
rslt.Offset(0, 1).Value = Application.Transpose(rg.Offset(i, 0))
Next
End Sub
Please note, the code must be run where the sheet contains the data is active.
Credit for code is for few editors in Mr . Excel forum. This code works like a charm, but I need it to copy the entire row of the new data, rather than only values from column A. Now I tried to play with true and false statements and etc. but to no avail, I believe it is out of my scope and id like so suggestions or assistance how to achieve my mission. I have simple values, no formulas, just some named columns and thousands of rows in original file and extract file.
Sub AddMissingItems()
Dim Dic As Object
Dim Arr() As Variant, outArr() As Variant
Dim i As Long, k As Long, iRow As Long
Dim c as long
Set Dic = CreateObject("Scripting.dictionary")
With Sheets("Sheet1")
c = .Cells(1, Columns.Count).End(xlToLeft).Column
Arr = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
For i = 1 To UBound(Arr, 1)
If Dic.exists(Arr(i, 1)) = False Then
Dic.Add (Arr(i, 1)), ""
End If
Next
End With
With Workbooks("ExtractFile").Worksheets("Sheet1")
Arr = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
ReDim outArr(1 To UBound(Arr), 1 To 1)
For i = 1 To UBound(Arr)
If Dic.exists(Arr(i, 1)) = False Then
k = k + 1
outArr(k, 1) = Arr(i, 1)
End If
Next
End With
iRow = Sheets("Sheet1").Range("A" & Rows.Count).End(3).Row + 1
If k <> 0 Then
Sheets("Sheet1").Range("A" & iRow).Resize(k).Value = outArr
k = 0
End If
End Sub
Tried adding Entirerow statement to several places, but to no avail.
Please, try the next adapted code. I commented where I input new variables/code lines:
Sub AddMissingItems()
Dim Dic As Object, Arr() As Variant, outArr() As Variant
Dim i As Long, k As Long, iRow As Long, c As Long
Dim r As Long, j As Long
Set Dic = CreateObject("Scripting.dictionary")
With Sheets("Sheet1")
Arr = .Range("A1:A" & .Range("A" & .rows.count).End(xlUp).row).Value
For i = 1 To UBound(Arr, 1)
If Dic.Exists(Arr(i, 1)) = False Then
Dic.Add (Arr(i, 1)), ""
End If
Next
End With
With Workbooks("ExtractFile.xlsx").Worksheets("Sheet1")
c = .cells(1, Columns.count).End(xlToLeft).column
r = .Range("A" & .rows.count).End(xlUp).row 'calculate the last row in A:A, too
Arr = .Range("A1", .cells(r, c)).Value 'place in the array all existing columns
ReDim outArr(1 To UBound(Arr), 1 To c) 'extend the redimmed array to all columns
For i = 1 To UBound(Arr)
If Dic.Exists(Arr(i, 1)) = False Then
k = k + 1
For j = 1 To c 'iterate between all array columns:
outArr(k, j) = Arr(i, j) 'place the value from each column
Next j
End If
Next
End With
iRow = Sheets("Sheet1").Range("A" & rows.count).End(3).row + 1
If k <> 0 Then
Sheets("Sheet1").Range("A" & iRow).Resize(k, UBound(Arr, 2)).Value = outArr 'resize by columns, too
k = 0
End If
End Sub
Please, send some feedback after testing it.
I've got two worksheets. The first (Calculation) contains 10.000 rows with a lot of RTD formulas and different calculations. The second (observer) observes the first one.
I've got a VBA script that runs every second and checks every row of worksheet 1 (Calculation). If the loop finds some marked data on worksheet 1 then it will copy some data from WS1 to WS2.
Solution 1: Loop checking 10.000 rows
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For I = 1 To 10000
If CStr(.Cells(I, 1)) = "X" Then
'DO SOME SUFF (copy the line from WS 1 to WS2)
'Find first empty row
LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
'Copy data from WS1 to WS2
WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
WS2.Cells(LR2, 1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Solution 2: Array function with a small loop
Can I use, instead of the 10.000 row loop, an Excel Array to observe the 10.000 rows and do some stuff with the smaller array.
On worksheet 2, I would have this code: (A1:O15)
{=index(Calculation!A$1:$O$10000; .....)....))}
Again I would have a smaller loop through the 15 lines of array function:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For K = 1 To 15
If CStr(.Cells(I, 1)) = "X" Then
'Find first empty row
LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
'Copy data from WS1 to WS2
WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
WS2.Cells(LR2, 1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I would like to know what solution has the better performance.
I am not sure if an Excel array over 10.000 rows has a good performance. For sure the 15-rowLoop is faster than a 10000-row-Loop.
I don't know how to measure if a 15-row Loop in connection with an array (observing 10.000 rows) is faster.
Copy to Sheet With Criteria
Copies each row of a dataset in a worksheet containing a specified value (Criteria) in a specified column, to another worksheet.
Adjust the values in the constants section of createReport.
The data transfer will only (always) happen when the worksheet "Observer" is activated e.g. when another sheet is currently selected and the "Observer" tab is clicked on.
This code took about 5 seconds for a million (all) rows, and under a second for 100.000 rows on my machine.
The efficiency can further be improved by using the code with the Worksheet Change event in the "Calculation" worksheet and by turning off certain Application events (e.g. .ScreenUpdating, .Calculation, .EnableEvents).
Excel Test Setup (Worksheet "Calculation")
[A1:I1] ="Column "&COLUMN()
[A2] =IF(I2=1,"X","Y")
[B2:H2] =RANDBETWEEN(1,1000)
[I2] =RANDBETWEEN(1,100)
Sheet Module (Worksheet "Observer")
Option Explicit
Private Sub Worksheet_Activate()
createReport
End Sub
Standard Module e.g. Module1
Option Explicit
Sub createReport()
' Constants
' Source
Const srcName As String = "Calculation"
Const CriteriaColumn As Long = 1
Const Criteria As String = "X"
Const srcFirstCellAddress As String = "A1"
' Target
Const tgtName As String = "Observer"
Const tgtFirstCellAddress As String = "A1"
Const includeHeaders As Boolean = True
' Other
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Range ('rng').
' Define Source First Cell ('cel').
Dim cel As Range
Set cel = wb.Worksheets(srcName).Range(srcFirstCellAddress)
' Define the Current Region ('rng') 'around' First Cell.
Dim rng As Range
Set rng = cel.CurrentRegion
' Define Source Range ('rng') i.e. exclude cells to the left and above
' of Source First Cell from the Current Region.
Set rng = rng.Resize(rng.Rows.Count - cel.Row + rng.Row, _
rng.Columns.Count - cel.Column + rng.Column) _
.Offset(cel.Row - rng.Row, cel.Column - rng.Column)
' Write values from Source Range to Data Array ('Data').
Dim Data As Variant
Data = rng.Value
' Write resulting values from Data Array to Data Array
' i.e. 'shift' them to the beginning.
Dim NoC As Long ' Number of Columns
NoC = UBound(Data, 2)
Dim i As Long ' Source Data Rows Counter
Dim j As Long ' Source/Target Data Columns Counter
Dim CurrentRow As Long ' Target Data Rows Counter
Dim checkHeaders As Long
checkHeaders = -CLng(includeHeaders) ' True is '-1' in VBA.
CurrentRow = checkHeaders
For i = 1 To UBound(Data, 1)
If Data(i, CriteriaColumn) = Criteria Then
CurrentRow = CurrentRow + 1
For j = 1 To NoC
' 'Shift' from 'i' to 'CurrentRow'.
Data(CurrentRow, j) = Data(i, j)
Next j
End If
Next i
' Write values from Data Array to Target Range ('rng').
' Define Target First Cell ('cel').
Set cel = wb.Worksheets(tgtName).Range(tgtFirstCellAddress)
' Define Target First Row ('rng').
Set rng = cel.Resize(, NoC)
' Clear contents in columns.
rng.Resize(rng.Worksheet.Rows.Count - cel.Row + 1).ClearContents
Select Case CurrentRow
Case 0
GoTo CriteriaNotFound
Case checkHeaders
' Write headers from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo CriteriaNotFound
Case Else
' Write values from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo Success
End Select
' Exit.
ProcExit:
Exit Sub
' Inform user.
CriteriaNotFound:
MsgBox "Value '" & Criteria & "' not found.", vbExclamation, "Fail"
GoTo ProcExit
Success:
MsgBox CurrentRow - checkHeaders & " row(s) of data transferred.", _
vbInformation, "Success"
GoTo ProcExit
End Sub
Rather than going back to column A 10,000 times, bring all the values into a 1D VBA array and then loop over that array:
Sub whatever()
Dim rng As Range, arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = WorksheetFunction.Transpose(rng)
For i = 1 To 10000
If arr(i) = "X" Then
'do some stuff
End If
Next i
End Sub
If there are very few X's then it may be nearly instantaneous.
EDIT#1:
Based on Chris Neilsen's comment, here is a version that does not use Transpose():
Sub whatever2()
Dim rng As Range, arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = rng
For i = 1 To 10000
If arr(i, 1) = "X" Then
'do some stuff
End If
Next i
End Sub
Test the next code, please. It should be very fast, using arrays and everything happening in memory. The code assumes that you need to copy all occurrences starting with the last empty cell of WS2:
Sub CopyFromWS1ToWs2Array()
Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
Dim LR2 As Long, arr1 As Variant, arr2 As Variant, i As Long, k As Long, j As Long
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range in an array
ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i, 1) = searchStr Then
k = k + 1 'the array row is incremented (in fact, it is the column now...)
For j = 1 To UBound(arr1, 2)
arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
Next j
End If
Next i
'the final array is Redim, preserving only the existing values:
ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
LR2 = WS2.cells(rows.count, 1).End(xlUp).row + 1 'last empty row of the second worksheet
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2).Select
MsgBox "Ready...", vbInformation, "Job done"
End Sub
Edited:
Please, test the next code, which should also solve your last requests (as I understood them):
Sub CopyFromWS1ToWs2ArrayBis()
Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
Dim LR2 As Long, arr1 As Variant, arr2 As Variant, arrWS2 As Variant
Dim i As Long, k As Long, j As Long, s As Long, boolFound As Boolean
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
LR2 = WS2.cells(rows.count, 1).End(xlUp).row 'last empty row of the second worksheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range of WS1 in an array
ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
arrWS2 = WS2.Range("A1:N" & LR2).Value 'put the range of WS2 in an array
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i, 1) = searchStr Then
For s = 1 To UBound(arrWS2)
If arr1(i, 1) = arrWS2(s, 1) And arr1(i, 2) = arrWS2(s, 2) And _
arr1(i, 3) = arrWS2(s, 3) Then
boolFound = True: Exit For 'if first three array columns are the same
End If
Next s
If Not boolFound Then 'if first thrree array columns not the same:
k = k + 1 'the array row is incremented
For j = 1 To UBound(arr1, 2)
arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
Next j
'swap the columns 4 and 5 values:
If arr1(i, 4) = "ABC" And arr1(i, 5) = "XYZ" Then arr2(4, k) = "XYZ": arr2(5, k) = "ABC"
End If
boolFound = False 'reinitialize the boolean variable
End If
Next i
If k > 0 Then
'Preserving only the existing array elements:
ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2 + 1).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2 + 1).Select
MsgBox "Ready...", vbInformation, "Job done"
Else
MsgBox "No any row to be copied!", vbInformation, "Nothing changed"
End If
End Sub
I have an excel range with 67 columns and about 4500 rows. The objective is to replace values in a row with hardcoded values in the 67th column of each row and then mark the ones that have have been replaced.
So I need to check each cell in a row (of 66 columns) and see if they satisfy a certain condition, before replacing them with the said hardcoded value at the very end of the row. My run time is about 360 seconds on average, when I mark the replaced values as Bold text.
Sub searchreplace()
Dim StartTime As Double
Dim Seconds As Double
StartTime = Timer
Dim i As Long
Dim j As Long
Dim arr As Variant
Dim myRange As Range
Dim Rng As String
Dim wb As Workbook
Dim SheetName As String
Dim LessThanEqual As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook
SheetName = "INPUT_WIND"
Rng = "C3:BQ4466"
LessThanEqual = 1
Set myRange = wb.Worksheets(SheetName).Range(Rng)
arr = myRange.Value
'i = rows = Ubound(arr,1)
'j=columns = Ubound(arr,2)
'loop through rows and clmns
For i = 1 To UBound(arr)
For j = 1 To myRange.Columns.Count
If arr(i, j) <= LessThanEqual Then
arr(i, j) = arr(i, 67)
myRange.Cells(i, j).Select
With Selection
.Font.Bold = True
End With
ElseIf IsEmpty(arr(i, j)) = True Then
arr(i, j) = arr(i, 67)
End If
Next j
Next i
myRange.Value = arr
Seconds = Round(Timer - StartTime, 2)
MsgBox "Fertig" & Seconds & "Seconds", vbInformation
Application.ScreenUpdating = True
End Sub
Instead of this:
myRange.Cells(i, j).Select
With Selection
.Font.Bold = True
End With
do this:
myRange.Cells(i, j).Font.Bold = True
It will be up to >10x faster.
See here for more: How to avoid using Select in Excel VBA
Here's a full example detailing using Union to keep track of which cells qualify to receive the bold, then apply that formatting in one shot. It's taking about a second on my machine to complete.
Option Explicit
Sub searchreplace()
Const LessThanEqual As Long = 1
Dim StartTime As Double
Dim i As Long
Dim j As Long
Dim arr As Variant
Dim myRange As Range
Dim wb As Workbook
Dim UnionRange As Range
StartTime = Timer
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set myRange = wb.Worksheets("INPUT_WIND").Range("C3:BQ4466")
arr = myRange.Value
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) To UBound(arr, 2)
If IsEmpty(arr(i, j)) = False And arr(i, j) <= LessThanEqual Then
If UnionRange Is Nothing Then
Set UnionRange = myRange.Cells(i, j)
Else
Set UnionRange = Union(UnionRange, myRange.Cells(i, j))
End If
ElseIf IsEmpty(arr(i, j)) Then
arr(i, j) = arr(i, 67)
End If
Next
Next
UnionRange.Font.Bold = True
myRange.Value = arr
Debug.Print "This took: " & Round(Timer - StartTime, 2) & " Seconds"
Application.ScreenUpdating = True
End Sub
I have a problem with a selfmade vba-code. The makro should solve the following problem: I use a "cockpitfile" It should load the elemts of two worksheets from two different Excel files into two Arrays. The Elements of these Arrays should be subtracted from each other. I want to get the difference from these two elements. As an example: ArrayElm1(1,1) - ArrayElm2(1,1) = ArrayElm3(1,1), ArrayElm1(1,2) - ArrayElm2(1,2) = ArrayElm3(1,2) etc.
On the first sight the code seems to work but when I check the results with my calculater the difference of the elements is wrong. Maybe there is a problem with the UBound because in my Ubound is only Array A?
Hope you can help me!
Sub Differenz1()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Variabledefinition
Dim i As Long 'Index
Dim j As Long 'Index
Dim k As Long 'Index
Dim ArrayA As Variant 'Array
Dim ArrayB As Variant 'Array
Dim ArrayC(71, 25) As Variant 'Array
Dim myFile1 As String 'Workbookname
Dim myFile2 As String 'Workbookname
Dim wb1 As String 'Workbookname
Dim wb2 As String 'Workbookname
Dim WS_Count1 As Integer 'Count Worksheets
Dim WS_Count2 As Integer 'Count Worksheets
Dim arrays1 As String 'Dimension
Dim arrays2 As String 'Dimension
'Change the actual path
ChDrive "O:\"
ChDir "O:..."
myFile1 = Application.GetOpenFilename
Workbooks.Open Filename:=myFile1, ReadOnly:=True, IgnoreReadOnlyRecommended:=True
wb1 = ActiveWorkbook.Name
WS_Count1 = ActiveWorkbook.Worksheets.Count
myFile2 = Application.GetOpenFilename
Workbooks.Open Filename:=myFile2, ReadOnly:=True, IgnoreReadOnlyRecommended:=True
wb2 = ActiveWorkbook.Name
WS_Count2 = ActiveWorkbook.Worksheets.Count
For k = 1 To WS_Count1
ArrayA = Workbooks(wb1).Worksheets(k).Range("F5:Y75").Value
ArrayB = Workbooks(wb2).Worksheets(k).Range("F5:Y75").Value
For i = LBound(ArrayA, 1) To UBound(ArrayA, 1)
For j = LBound(ArrayA, 2) To UBound(ArrayA, 2)
If Not IsError(ArrayA(i, j)) And Not IsError(ArrayB(i, j)) Then ArrayC(i, j) = ArrayA(i, j) - ArrayB(i, j)
Next j
Next i
ThisWorkbook.Worksheets(k + 1).Range("F5:Y75").Value = ArrayC
Next k
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
You almost had it right, but the issues was that you didn't reset ArrayC
This code creates new sheets in ThisWorkbook for subtractions, and based on your previous question it checks for errors, and performs the subtractions only if both values are numbers
Option Explicit
Public Sub Differenz2()
Const USED_RNG = "F5:Y75" 'Main range
Dim i As Long, j As Long, k As Long, file1 As String, file2 As String, ws1Count As Long
Dim wb1 As Workbook, wb2 As Workbook, arr1 As Variant, arr2 As Variant, arr3 As Variant
'ChDrive "O:\": ChDir "O:..."
file1 = Application.GetOpenFilename: If file1 = "False" Then Exit Sub
file2 = Application.GetOpenFilename: If file2 = "False" Then Exit Sub
Application.ScreenUpdating = False
Set wb1 = Workbooks.Open(Filename:=file1, ReadOnly:=True)
Set wb2 = Workbooks.Open(Filename:=file2, ReadOnly:=True)
ws1Count = wb1.Worksheets.Count
If ws1Count = wb2.Worksheets.Count Then
MakeNewWS ws1Count 'Remove this line if ThisWorkbook is properly setup
For k = 1 To ws1Count
arr1 = wb1.Worksheets(k).Range(USED_RNG).Value
arr2 = wb2.Worksheets(k).Range(USED_RNG).Value
ReDim arr3(1 To 71, 1 To 20) 'reset array, based on USED_RNG ("F5:Y75")
For i = LBound(arr1, 1) To UBound(arr1, 1)
For j = LBound(arr1, 2) To UBound(arr1, 2)
If Not IsError(arr1(i, j)) And Not IsError(arr2(i, j)) Then
If IsNumeric(arr1(i, j)) And IsNumeric(arr2(i, j)) Then
arr3(i, j) = arr1(i, j) - arr2(i, j)
End If
End If
Next
Next
ThisWorkbook.Worksheets(k + 1).Range(USED_RNG) = arr3
Next
End If
wb1.Close False: wb2.Close False: ThisWorkbook.Worksheets(2).Activate
Application.ScreenUpdating = True
End Sub
Private Sub MakeNewWS(ByVal wsCount As Long)
Dim i As Long, ws As Worksheet
With ThisWorkbook.Worksheets
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
If Left(ws.Name, 12) = "Subtraction " Then
If .Count = 1 Then .Add
ws.Delete
End If
Next
Application.DisplayAlerts = True
For i = 2 To wsCount + 1
.Add After:=ThisWorkbook.Worksheets(.Count)
ThisWorkbook.Worksheets(.Count).Name = "Subtraction " & i - 1
Next
End With
End Sub
You can ignore the MakeNewWS() sub if ThisWorkbook contains the proper number of sheets
Also, using arrays does improve performance (significantly)