I'm trying to update a sheet with information from a filled in previous version.
It is a repeating block which moves down 13 rows eacht time. So trying to loop in combination with copying my selection, since there are only 11 values I need (the 1st and 13th contain information I do not want to overwrite)
The code I use is the following.
Sub Get_Data_From_File()
Dim FileToOpen As Variant, i As Long, KolB As Long, KolG As Long
Dim OpenBook As Workbook
Dim m As Integer, n As Integer
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Select file to import", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
For i = 1 To 53
m = -8 + i * 13
n = 2 + i * 13
With ActiveSheet
.Blad2.Range("B" & m & ":G" & n).Select
*' .Blad2.Range("B" & CStr(m) & ":G" & CStr(n)).Copy*
ThisWorkbook.Worksheets("blad2").Range("B" & CStr(m) & ":G" & CStr(n)).PasteSpecial xlPasteValues
End With
Next i
OpenBook.Close False
End If
Application.ScreenUpdating = True
End Sub
when I use this, I get a 483 error in the line ".Blad2.Range("B" & CStr(m) & ":G" & CStr(n)).Copy"
so I tried it with the " .Blad2.Range("B" & m & ":G" & n).Select" line
It does not seem to work. If you have any ideas, that would be appreciated.
thanks in advance
Related
Every morning I have to compare manually row by row the information in my database with the one sent by the broker. Normally they should have exactly the same information.
The information is about executed trades.
1- I need to compare row by row looking at the values "Stock", "Qty", "Price" and "Date". If any row is not matched from each other (i.e. a value is erroneously different in one of the table or the entire row is missing), I need the unmatched rows to be printed in a third "OUTPUT" table.
My TABLE, BROKER'S TABLE & OUTPUT
2- The thing here is that there are duplicates like for "microsoft" or "nvidia" that are independent trades (different IDs). Duplicates must be kept in the comparison because they are different trades.
How could I manage the duplicates problems? Using Collections in Dictionary could help me? I would compare Table A to Table B and then Table B to Table A.
Or the presence of duplicates (actually independent trades) makes it impossible to perform ?
My file has more than 500 rows.
I'll add an entirely in-memory way to achieve the output.
The one thing worth considering is that we have no way of differentiating one ID from the next if they have matching stock, price, qty, and dates. So, the way I'm handling duplicates is in the order that they appear in the spreadsheet. So if there are two matching entries in your table, and only 1 in the broker table, I assume that the first entry in your table matches the first entry in the broker table, and therefore your second entry will be output.
Try working through the code. I took a few shortcuts for the sake of timing, but I also encapsulated each of the functions so that you can modify as needed. You'll just have to build out the DeserializeKey function to convert a key back to cells in the output sheet (shouldn't be too hard). See the below code, and let me know if it meets expectations.
Note: You will run the "CompareDictionaries" subroutine. The others are helper functions.
Sub CompareDictionaries()
Dim oMine As Object
Dim oBroker As Object
Dim myQueueCount As Long
Dim brokerQueueCount As Long
Dim minQueue As Long
Dim oMinQueue As Object
Set oMine = GetDictionary(Sheet1.Range("A2:E7"))
Set oBroker = GetDictionary(Sheet2.Range("A2:E6"))
For Each oKey In oMine.keys
'The whole row does not exist in the broker table
If Not oBroker.Exists(oKey) Then
Do While oMine(oKey).Count > 0
DeserializeKey oKey, oMine(oKey).dequeue
Loop
Else 'The keys exist in both tables
myQueueCount = oMine(oKey).Count
brokerQueueCount = oBroker(oKey).Count
If myQueueCount = brokerQueueCount Then
'Do nothing. They both have the same number of
'id's, and so we assume they are in sync.
Else
'Determine the minimum queue size, and get rid
'of that many values, since we won't need them
minQueue = IIf(myQueueCount < brokerQueueCount, myQueueCount, brokerQueueCount)
For i = 1 To minQueue
oMine(oKey).dequeue
oBroker(oKey).dequeue
Next i
'Take the remaining IDs out of the dictionary/queue that had more
If brokerQueueCount > myQueueCount Then
Set oMinQueue = oBroker
Else
Set oMinQueue = oMine
End If
Do While oMinQueue(oKey).Count > 0
DeserializeKey oKey, oMinQueue(oKey).dequeue
Loop
End If
End If
Next oKey
'The only remaining thing to test for is keys in the broker dict
'that are not in the myDict
For Each oKey In oBroker.keys
If Not oMine.Exists(oKey) Then
Do While oBroker(oKey).Count > 0
DeserializeKey oKey, oBroker(oKey).dequeue
Loop
End If
Next oKey
End Sub
Function GetDictionary(inputRange As Range) As Object
Dim oDict As Object
Dim sht As Worksheet
Dim cel As Range
Dim theKey As String
Dim oQueue As Object
Set sht = inputRange.Parent
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In Intersect(inputRange, sht.Columns(1))
theKey = GenerateKey(cel.Resize(, 5))
If oDict.Exists(theKey) Then
oDict(theKey).enqueue cel.Value
Else
Set oQueue = CreateObject("System.Collections.Queue")
oQueue.enqueue cel.Value
oDict.Add theKey, oQueue
End If
Next cel
Set GetDictionary = oDict
End Function
Sub DeserializeKey(ByVal theKey As String, theId As String)
'This is where you'd do some stuff to
'turn the key into individual cells, and store it.
'I'm only writing to the debug widnow to demonstrate
Debug.Print theId & " " & theKey
End Sub
Function GenerateKey(rng As Range) As String
GenerateKey = rng(2) & Format(rng(3), "0") _
& Format(rng(4), "0.00") & Format(rng(5), "mmddyyyy")
End Function
For those interested in this method, I'm editing this answer to add the "deserializekey" function:
Dim r As Long
Worksheets("Output").Activate
r = 1
'What we are doing here with "loopcell" is to check if the destination cells in the "output" sheet are empty or free.
'If not, we go down 1 row.
loopcell:
If IsEmpty(Range("A" & r).Value) = True Then
Range("A" & r).Value = "_" & theId & "_" & theKey
Else
r = r + 1
GoTo loopcell
End If
'The key is wrote to the the cell but we need to split every element of the key in multiple cells.
splitOutput = Range("A" & r).Value
splitArray = Split(splitOutput, "_")
For i = 1 To UBound(splitArray)
Cells(r, i).Value = splitArray(i)
Next i
Debug.Print theId & " " & theKey
End Sub ```
** New GetDictionary and Deserialize methods used to store more info **
Sub DeserializeKey(ByVal theKey As String, theId As Variant)
'This is where you'd do some stuff to
'turn the key into individual cells, and store it.
'I'm only writing to the debug widnow to demonstrate
Dim output As String
'Keep in mind that we have a 2d array, and we are reading
'one row at a time. So get the number of columns in the
'array, and then do whatever you need with them.
For i = LBound(theId, 2) To UBound(theId, 2)
output = output & " " & theId(1, i)
Next i
Debug.Print theKey & " -->" & output
End Sub
Function GetDictionary(inputRange As Range) As Object
Dim oDict As Object
Dim sht As Worksheet
Dim cel As Range
Dim theKey As String
Dim oQueue As Object
Dim columnCount As Long
Dim rngAsArray As Variant
Set sht = inputRange.Parent
'Get the column count of the input range. Since we don't
'hardcode it in, this function is more flexible to
'future changes
columnCount = inputRange.Columns.Count
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In Intersect(inputRange, sht.Columns(1))
theKey = GenerateKey(cel.Resize(, 5))
'Put the full row into an array, which we will then
'store as the content of the queue
rngAsArray = cel.Resize(, columnCount).Value
If oDict.Exists(theKey) Then
oDict(theKey).enqueue rngAsArray
Else
Set oQueue = CreateObject("System.Collections.Queue")
oQueue.enqueue rngAsArray
oDict.Add theKey, oQueue
End If
Next cel
Set GetDictionary = oDict
End Function
First of all, please read DS_London's comment.
If you would like to have a result sheet, then you can use below macro:
Option Explicit
Sub CompareData()
Dim wbk As Workbook
Dim wshMyData As Worksheet, wshBrokersData As Worksheet, wshResult As Worksheet
Dim i As Integer, j As Integer, k As Integer
Dim sTmp As String
On Error Resume Next
Set wbk = ThisWorkbook
Set wshResult = wbk.Worksheets("Result")
On Error GoTo Err_CompareData
'if there_s no result sheet
If Not wshResult Is Nothing Then
Application.DisplayAlerts = False
wbk.Worksheets("Result").Delete
Application.DisplayAlerts = True
End If
Set wshMyData = wbk.Worksheets("Sheet1")
Set wshBrokersData = wbk.Worksheets("Sheet2")
Set wshResult = wbk.Worksheets.Add(After:=wshBrokersData)
wshResult.Name = "Result"
wshResult.Range("A1") = "ID"
wshResult.Range("B1") = "Stock"
wshResult.Range("C1") = "Qty"
wshResult.Range("D1") = "Price"
wshResult.Range("E1") = "Date"
wshResult.Range("F1") = "My"
wshResult.Range("G1") = "Broker"
wshResult.Range("A1:G1").Interior.Color = vbGreen
'find last entry in your data
i = wshMyData.Range("A" & wshMyData.Rows.Count).End(xlUp).Row
'find last entry in brokers data
j = wshBrokersData.Range("A" & wshBrokersData.Rows.Count).End(xlUp).Row
'copy data into result sheet
k = 2
wshMyData.Range("A2:E" & i).Copy wshResult.Range("A" & k)
k = k + i - 1
wshBrokersData.Range("A2:E" & j).Copy wshResult.Range("A" & k)
k = k + j - 2
'remove duplicates
wshResult.Range("$A$1:$E$" & k).RemoveDuplicates Columns:=Array(2, 3, 4, 5), Header:=xlYes
k = wshResult.Range("A" & wshResult.Rows.Count).End(xlUp).Row
'start comparison ;)
'my data
sTmp = "(" & wshMyData.Name & "!" & wshMyData.Range("B1:B" & i).AddressLocal & "=B2)"
sTmp = sTmp & "*(" & wshMyData.Name & "!" & wshMyData.Range("C1:C" & i).AddressLocal & "=C2)"
sTmp = sTmp & "*(" & wshMyData.Name & "!" & wshMyData.Range("D1:D" & i).AddressLocal & "=D2)"
sTmp = sTmp & "*(" & wshMyData.Name & "!" & wshMyData.Range("E1:E" & i).AddressLocal & "=E2)"
sTmp = "=SUM(IF(" & sTmp & ", 1, 0))"
wshResult.Range("F2").BorderAround LineStyle:=xlContinuous
wshResult.Range("F2").FormulaArray = sTmp
wshResult.Range("F2:F" & k).FillDown
'brokres data
sTmp = "(" & wshBrokersData.Name & "!" & wshBrokersData.Range("B1:B" & i).AddressLocal & "=B2)"
sTmp = sTmp & "*(" & wshBrokersData.Name & "!" & wshBrokersData.Range("C1:C" & i).AddressLocal & "=C2)"
sTmp = sTmp & "*(" & wshBrokersData.Name & "!" & wshBrokersData.Range("D1:D" & i).AddressLocal & "=D2)"
sTmp = sTmp & "*(" & wshBrokersData.Name & "!" & wshBrokersData.Range("E1:E" & i).AddressLocal & "=E2)"
sTmp = "=SUM(IF(" & sTmp & ", 1, 0))"
wshResult.Range("G2").BorderAround LineStyle:=xlContinuous
wshResult.Range("G2").FormulaArray = sTmp
wshResult.Range("G2:G" & k).FillDown
'autofit
wshResult.Range("A:G").Columns.AutoFit
Exit_CompareData:
On Error Resume Next
Set wshMyData = Nothing
Set wshBrokersData = Nothing
Set wshResult = Nothing
Set wbk = Nothing
Exit Sub
Err_CompareData:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_CompareData
End Sub
Result:
As you can see, 0 means that there's no corresponding data in selected sheet.
What above macro does?
Adds new sheet: Result, then adds column headers (ID, Stock, Qty, Price, Date, My data, Broker in row 1 respectively in columns A-G)
Copies all data from your sheet (Sheet1) to Result sheet
Copies all data from broker's sheet (Sheet2) to Result sheet
Removes duplicates in Result sheet (based on all columns excluding ID)
Inserts formula-array in cell F2 and G2 and fill it down.
Important note: There's at least few other ways to achieve that...
Final note: Feel free to change the code to your needs.
I have a code that counts the rows in column A and then runs this array formula in the corresponding rows in other columns, I am wondering if it's possible to have the code run +10 more times than the last row.
For example if there are only populated fields in Column A2 and A3, I would like this code to run 12 times from J2-J14 so it takes the last row +10 if this is possible?
Thank you in advance :)
Dim i As Integer
Dim lastRow As Integer
lastRow = Range("A" & Rows.count).End(xlUp).Row
For i = 1 To lastRow
Range("J" & i + 1).FormulaArray = "=IFERROR(INDEX('Z:\Customer Operations\[O.xlsx]S'!$A:$A, SMALL(IF(A2='Z:\Customer Operations\[O.xlsx]S'!$K:$K, ROW('Z:\Customer Operations\[O.xlsx]S'!$A:$A)-MIN(ROW('Z:\Customer Operations\[O.xlsx]S'!$A:$A))+1, """"), ROW(A" & i & "))),"""")"
Range("K" & i + 1).FormulaArray = "=IFERROR(INDEX('Z:\Customer Operations\[O.xlsx]S'!$D:$D, SMALL(IF(A2='Z:\Customer Operations\[O.xlsx]S'!$K:$K, ROW('Z:\Customer Operations\[O.xlsx]S'!$D:$D)-MIN(ROW('Z:\Customer Operations\[O.xlsx]S'!$D:$D))+1, """"), ROW(A" & i & "))),"""")"
Next i
For i = 2 To 50
Range("L" & i).Formula = "=IF(J" & i & "="""","""",SUMIFS(E:E,D:D,J" & i & "))"
Next
Try,
Dim LastRow As Integer
'// ADD 10 to lastrow
LastRow = Range("A" & Rows.Count).End(xlUp).Row + 10
'// formulas
Range("J2:J" & LastRow).FormulaArray = "=IFERROR(INDEX('Z:\Customer Operations\[O.xlsx]S'!$A:$A, SMALL(IF(A2='Z:\Customer Operations\[O.xlsx]S'!$K:$K, ROW('Z:\Customer Operations\[O.xlsx]S'!$A:$A)-MIN(ROW('Z:\Customer Operations\[O.xlsx]S'!$A:$A))+1, """"), ROW(A2))),"""")"
Range("K2:K" & LastRow).FormulaArray = "=IFERROR(INDEX('Z:\Customer Operations\[O.xlsx]S'!$D:$D, SMALL(IF(A2='Z:\Customer Operations\[O.xlsx]S'!$K:$K, ROW('Z:\Customer Operations\[O.xlsx]S'!$A:$A)-MIN(ROW('Z:\Customer Operations\[O.xlsx]S'!$A:$A))+1, """"), ROW(A2))),"""")"
'// formulas
Range("L2:L50").Formula = "=IF(J2="""","""",SUMIFS(E:E,D:D,J2))"
If A2 is fixed then use $A$2 for small function
This works to put the values in the column:
Sub JR_ArrayToDebugPint2()
' written by Jack in the UK for [url]www.OzGrid.com[/url]
' our web site [url]www.excel-it.com[/url]
' Excel Xp+ 14th Aug 2004
' [url]http://www.ozgrid.com/forum/showthread.php?t=38111[/url]
Dim JR_Values(500)
Dim JR_Count As Integer
Dim R As Long
R = 2
For JR_Count = 1 To 500 Step 1
JR_Values(JR_Count) = Evaluate("=INDEX('Client'!$O$2:$O$347473,MATCH(1,(('Client_Cost'!$D$2:$D$347473=BC" & CStr(R) & ")*('Client_Cost'!$E$2:$E$347473=BE" & CStr(R) & ")),0))")
Sheet1.Range("BG" & CStr(R) & "").Value = JR_Values(JR_Count)
R = R + 1
'Debug.Print JR_Values(JR_Count)
Next JR_Count
End Sub
I've modified the original code I found on mrexcel.com
I get the correct list of values whether I Debug.Print or print to the worksheet. So in my mind, I ought to be able to put the values in an array as they are calculated, then use Range("BG2:BG500").Value = Application.Transpose(myarray).
I am assuming if I do this the values will be placed in the cells in the column all at once, rather than one at a time, which is what this code, and all others I've tried, is doing. I am also assuming that, if the values are placed in the cells in the column all at once, it is MUCH faster than placing the values in the cells one at a time.
What I'm not able to do is get the code to put the value in an array once the formula is evaluated. I've tried variations of the following with no success - statements to set the array and have the array take the value of the calculation are in caps and marked by ==>. The most common error I get is type mismatch.
Sub JR_ArrayToDebugPint2()
Dim JR_Values(500)
Dim JR_Count As Integer
Dim R As Long
==> DIM arrPRICE(0 TO 500) AS VARIANT
R = 2
For JR_Count = 1 To 500 Step 1
JR_Values(JR_Count) = Evaluate("=INDEX('Client'!$O$2:$O$347473,MATCH(1,(('Client_Cost'!$D$2:$D$347473=BC" & CStr(R) & ")*('Client_Cost'!$E$2:$E$347473=BE" & CStr(R) & ")),0))")
==> arrPRICE(R) = JR_VALUES(JR_COUNT)
R = R + 1
'Debug.Print JR_Values(JR_Count)
Next JR_Count
End Sub
When you dimension the variant array like Dim JR_Values(500) you are creating a one-dimensioned array based upon a zero-based index. This first element within the array is JR_Values(0) and the last is JR_Values(500) for a total of 501 array elements. While you could work from 0 to 499 with a little math, you can also force a one-based index on the variant array by declaring it that way.
The assumed worksheet parentage of the BC and BE columns where the individual row data criteria comes from is not definitive when using Application Evaluate like it is when the same formula is used on a worksheet. A worksheet knows who it is; VBA may or may not know what worksheet you are implying.
Sub JR_ArrayToDebugPint2()
Dim olr As Long, rws As Long, JR_Count As Long, JR_Values As Variant
'get some dimensions to the various data ranges
With Worksheets("Client_Cost")
'only use as many rows as absolutely necessary
olr = Application.Min(.Cells(Rows.Count, "C").End(xlUp).Row, _
.Cells(Rows.Count, "E").End(xlUp).Row)
End With
With Worksheets("Client")
rws = Application.Min(.Cells(Rows.Count, "BC").End(xlUp).Row, _
.Cells(Rows.Count, "BE").End(xlUp).Row)
'override the above statement unless you want to run this overnight
rws = 500
End With
ReDim JR_Values(1 To rws) 'force a one-based index on the array
'Debug.Print LBound(JR_Values) & ":" & UBound(JR_Values)
For JR_Count = LBound(JR_Values) To UBound(JR_Values) Step 1
'Debug.Print Evaluate("INDEX('Client'!O2:O" & olr & _
", MATCH(1, (('Client_Cost'!D2:D" & olr & "='Client'!BC" & JR_Count+1 & ")" & _
"*('Client_Cost'!E2:E" & olr & "='Client'!BE" & JR_Count+1 & ")), 0))")
'R would be equal to JR_Count + 1 if R was still used (starts as R = 2)
JR_Values(JR_Count) = _
Evaluate("INDEX('Client'!O2:O" & olr & _
", MATCH(1, (('Client_Cost'!D2:D" & olr & "='Client'!BC" & JR_Count + 1 & ")" & _
"*('Client_Cost'!E2:E" & olr & "='Client'!BE" & JR_Count + 1 & ")), 0))")
'Debug.Print JR_Values(JR_Count)
Next JR_Count
With Worksheets("Client")
.Range("BG2").Resize(UBound(JR_Values), 1) = Application.Transpose(JR_Values)
End With
End Sub
I've left a lot of comments for you to review and subsequently clean up. I recently wrote a narrative of declaring one-dimension and two-dimension variant arrays in How to assign the variable length of an array to integer variable.
I have the following code which scans a list of raw data and for each line and if date and var (a variant I defined) are correct the row is copied and placed into the correct destination. This line to copy row is commented out. The macro worked but instead of copying the whole row I've now attempted (in the 2 lines above the commented out .copy row) to select only specific cells in the row (cells in iRow and columns M,N,O,Q,R,U,V,AB). I get the error: Wrong number of arguments or invalid property assignment. I know this is related to the 2 new lines of code I input because previously the code worked fine. Any help is appreciated, thanks!
Sub currentMonthDetail()
Dim csCount As Range
Dim b As Variant
Dim shrow As Long
Dim iRow As Long, iRowL As Long, var As Variant, iDate As Variant
Dim bln As Boolean
Dim s As String
Dim eRow As Integer
Dim i As Integer
'Import monthly data from GL008 tab to detail-----------------------------------------------------------------
Set csCount = Worksheets("Input").Range("csCount")
Sheets("GL008").Activate
iRowL = Cells(rows.count, 1).End(xlUp).Row
For iRow = 2 To iRowL
Sheets("GL008").Activate
If Not IsEmpty(Cells(iRow, 35)) Then
bln = False
var = Application.Match(Cells(iRow, 35).Value, Worksheets("Input").Columns(3), 0)
iDate = Sheets("GL008").Cells(iRow, 34)
If Not CVErr(var) = CVErr(xlErrNA) And iDate = Worksheets("Input").Range("E3") Then
Sheets("GL008").Activate
Range("M" & iRow, "N" & iRow, "O" & iRow, "Q" & iRow, "R" & iRow, "U" & iRow, "V" & iRow, "AB" & iRow).copy
'Sheets("GL008").rows(iRow).copy
s = Sheets("GL008").Cells(iRow, 35)
Sheets(s).Activate
eRow = Sheets(s).Cells(rows.count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Sheets(s).rows(eRow)
End If
End If
Next iRow
You are passing lots of cells to Range. When you try to do that, it's looking for a top-left start cell, a lower-right end cell, and will make a rectangle selection from one to the other.
Because you're trying to give it 8 separate parameters, it can't handle it. You need to give it 1 parameter, which contains the cell list; make them all into one string, and then give that string as one parameter to range.
i.e. put the commas into the text.
Range("M" & iRow & ",N" & iRow & ",O" & iRow & ",Q" & iRow & ",R" & iRow & ",U" & iRow & ",V" & iRow & ",AB" & iRow).copy
I'm trying to convert a list in Excel VBA as follows:
My original list in the one colored in grey. It shows a sequence.
I want to generate the list on the right according to each number location.
For example:
3 is second in the left list so 2 is on the third location in the right list;
6 is fourth in the left list so 4 is on the sixth location in the right list ...
I tried using 'For' loops in VBA, but it's getting a bit long and complex, is there a way to do it by using arrays in VBA?
A formula can easily achieve this. Assuming data is in A1:A8, in B1 and copied down:
=MATCH(ROW(),A$1:A$8,0)
This will work, just set the first, last and ranges as needed.
Private Sub cbSort_Click()
Dim wArray As Variant, dArray As Variant
Dim first As Integer, last As Integer
Dim i As Integer, j As Integer
first = 1
last = 8
Set wArray = Range("A" & first & ":A" & last)
ReDim dArray(1 To last - first + 1, 1 To 1)
j = 1
For i = first To last
dArray(wArray(i, 1), 1) = j
j = j + 1
Next i
Range("B" & first & ":B" & last) = dArray
End Sub
Option Explicit
Sub Main()
Dim source As Range
On Error GoTo ErrTransformIt
Set source = Application.InputBox(prompt:="Source", Type:=8)
TransformIt source
Exit Sub
ErrTransformIt:
MsgBox Err.Description
End Sub
Private Sub TransformIt(ByVal source As Range)
Dim target As Range
Dim c As Range
Dim i As Integer
Dim firstRow As Long
firstRow = source(1).Row
i = 1
For Each c In source.Cells
Set target = ActiveSheet.Cells(firstRow + c.Value - 1, c.Column + 1)
If target.Value <> "" Then
MsgBox "Target is already used by [" & target.Value & "]", vbExclamation
Exit Sub
End If
target.Value = i
i = i + 1
Next c
End Sub