I have a worksheet (in my desktop) which have over 13.000 rows with duplicate data which I add 3 new column with vlookup from another file (called ProductList) located on sharedrive. I tried to use Dictionary but I don't know how can I add a different workbook to my code? I add ProductList to my file as Sheet2 and successfully run the code.
Sub ckv()
Dim Rng As Range, Dn As Range, n As Long, Tic As Object, ray As Variant
'This is normally my ProductList workbook, which has 4 columns
With Sheets("Sheet2")
ray = .Range("A1").CurrentRegion.Resize(, 4)
End With
Set Tic = CreateObject("scripting.dictionary")
Tic.CompareMode = vbTextCompare
For n = 2 To UBound(ray, 1)
Tic(ray(n, 1)) = n
Next
'And this is my file in my desktop
With Sheets("Sheet1")
Set Rng = .Range(.Range("I2"), .Range("I" & Rows.Count).End(xlUp))
For Each Dn In Rng
If Tic.Exists(Dn.Value) Then
Dn.Offset(, -2) = ray(Tic(Dn.Value), 2)
Dn.Offset(, -1) = ray(Tic(Dn.Value), 3)
Dn.Offset(, 1) = ray(Tic(Dn.Value), 4)
End If
Next Dn
End With
End Sub
regards
Related
I need the expert help in VBA as I am new. Actually I am looking for Vba code for Consecutive Count on the bases of two column (Serial Number and Alert Code) on button click event. The Column row are not fixed (dynamically change). The Consecutive count is maximum repeat count for Alert Code per Serial number. This should display in output worksheet as per max repeat Alert count per Serial number
Input Worksheet:
Expected Output :
The repeat count work as below pattern from Input sheet (Just for reference only).
Mine source code as below but this does not reference the 1st Column Serial Number (This only work for One column like AlertCode) :
Sub ConsecutiveCount()
Dim lr As Long, c As Range, a As Long
Application.ScreenUpdating = False
lr = Worksheets("Count2").Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range("B2:B" & lr)
If c.Value <> c.Offset(1).Value Then
a = Cells(c.Row, 3).End(xlUp).Row
' Range(Cells(c.Row, 4), Cells(c.Row, 4).End(xlUp).Offset(1)).Value = c.Row - a
Cells(c.Row, 3).Value = c.Row - a
Else
End If
Next c
Application.ScreenUpdating = True
End Sub
Current Output (Serial number not included)
Screenshot(s) / here(♪) refers:
Named ranges/setup
First, define a couple of named ranges to assist with referencing / formulating in VBA:
Name: range_data: dynamic range that references the two columns of interest (here, col 1&2 in Sheet1):
Refers to: =Sheet1!$D$3:OFFSET(Sheet1!$E$3,COUNTA(Sheet1!$E$3:$E$99995)-1,0,1,1)
Name: range_summary_startcell: a static range that references the desired upper-left cell of the output table / summary.
Refers to: =Sheet1!$G$3
The summary table itself shall comprise a number of rows (depending upon range_data) and 3 columns (given the input/Q) - this will be produced by the macro (code below) and can be seen in screenshot above (G3:I5) - the macro functions shall determine the appropriate dimensions automatically
Code
With these two named ranges (i.e. 'range_data' & 'range_summary_startcell') defined, the following VB code produces the desired output per your Q:
Sub Macro_Summary()
'
'JB_007 07/01/2022
'
'
Application.ScreenUpdating = True
Range("range_summary_startcell").Select
ActiveCell.Formula2R1C1 = "=UNIQUE(range_data)"
ActiveSheet.Calculate
x = ActiveCell.End(xlDown).Row
Set range_count = ActiveCell.Offset(0, 2)
range_count.Select
range_count.Formula2R1C1 = _
"=COUNTIFS(INDEX(range_data,0,2),RC[-1],INDEX(range_data,0,1),RC[-2])"
Selection.AutoFill Destination:=Range(range_count, range_count.Offset(x - range_count.Row))
ActiveSheet.Calculate
End Sub
Caveats: assumes you have Office 365 compatible version of Excel
GIF - Running Macro
Notes (♪) saved as macro-free workbook for your own security if you wish to download underlying workbook - otherwise identical to screenshot(s) in this proposed soln.
Sub ConsecutiveCount()
Dim srcLastRow As Long, cntConsec As Long, i As Long
Dim rng As Range
Dim srcArr() As Variant
Dim srcSht As Worksheet
Dim destsht As Worksheet
Dim destArr() As Variant
Dim combID As String
Dim splitID As Variant
Application.ScreenUpdating = False
Set srcSht = Worksheets("Input")
Set destsht = Worksheets("Output")
With srcSht
srcLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 ' include 1 blank line
srcArr = .Range(.Cells(2, "A"), .Cells(srcLastRow, "B"))
End With
Dim dict As Object
Dim dKey As Variant
Set dict = CreateObject("Scripting.dictionary")
cntConsec = 0
For i = LBound(srcArr) To UBound(srcArr)
cntConsec = cntConsec + 1
If i <> UBound(srcArr) Then
If srcArr(i, 1) <> srcArr(i + 1, 1) Or srcArr(i, 2) <> srcArr(i + 1, 2) Then
combID = srcArr(i, 1) & "|" & srcArr(i, 2)
If dict.Exists(combID) Then
' check if sum is more
If dict(combID) < cntConsec Then ' If new max for combination
dict(combID) = cntConsec
End If
Else
' add to dictionary
dict(combID) = cntConsec
End If
cntConsec = 0
End If
End If
Next i
ReDim destArr(1 To dict.Count, 1 To 3)
i = 0
For Each dKey In dict.keys
splitID = Split(dKey, "|")
i = i + 1
destArr(i, 1) = splitID(0)
destArr(i, 2) = splitID(1)
destArr(i, 3) = dict(dKey)
Next dKey
destsht.Range("A2").Resize(UBound(destArr), 3).Value = destArr
Application.ScreenUpdating = True
End Sub
My ultimate goal is to read a range from one workbook and input it into specific cells in another workbook. The source Workbook has a range of autofiltered data in columns A-D. The destination workbook has 8 fields that need to be filled and they will always be the same. For instance, The source workbook will have the first field of the Array MyArray(x) go into the field B2 on the destination workbook. Then MyArray(x) will have x=2 which will populate D2 in the destination workbook from the next visible row in column B. So, it would look like this:
Source workbook
A
B
C
D
1
User Name
AccountNo
Last3
Software to Load
3
User 2
10161_4002
MM1
License E3
4
User 3
10202_2179
118
6
User 5
10141_9863
AA5
License-E3,Reflection
7
User 6
10167_3006
B35
RSI,Java
9
User 8
10176_3393
W45
Office365,Java
And the destination workbook would look like this:
A
B
C
D
1
2
Name:
Account Number:
3
ID:
Software:
4
5
Name:
Account Number:
6
ID:
Software:
So, after running to sub/function, I would have:
[D]=Destination [S]=Source
[D]B2=[S]A3
[D]D2=[S]B3
[D]B3=[S]C3
[D]D3=[S]D3
[D]B5=[S]A4
[D]D5=[S]B4
[D]B6=[S]C4
[D]D6=[S]D4
And so on with 2 rows from the source getting put into the 8 fields of the destination workbook. I have some very basic code at this point but I know this is pretty convoluted. Here is what I've come up with so far which just loops through all of the visible rows and prints out the lines from the range from A2 through the last cell in D with data in it to the immediate window. I've removed it from my main project and just put it all in 2 new workbooks to simplify everything. Ultimately, I'm going to print each page when the destination gets all 8 fields updated and move on to the next page. My code so far:
Sub AddToPrintoutAndPrint()
Dim rng As Range, lastRow As Long
Dim myArray() As Variant, myString() As String
Dim cell As Range, x As Long, y As Long
Dim ws As Worksheet: Set ws = Sheet1 ' Sheet1
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set rng = Range("A2:D" & lastRow)
For Each cell In rng.SpecialCells(xlCellTypeVisible)
ReDim Preserve myArray(x)
myArray(x) = cell.Value
x = x + 1
Next cell
For x = LBound(myArray) To UBound(myArray)
Debug.Print Trim$(myArray(x))
Next x
Set ws = Nothing
End Sub
Thanks for any suggestions
Edit: New block of code to support printing multiple lines
Sub RunIt()
Dim rng As Range
Dim lastRow As Long
Dim ws As Worksheet
Dim coll As Collection
Dim wsDest As Worksheet
Dim rowCounter As Integer
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set wsDest = Sheets("Sheet2")
Set rng = Range("A2:A" & lastRow)
Set coll = GetUserInfo(rng.SpecialCells(xlCellTypeVisible))
'This is used to keep a running total of how many rows
'were populated. Since the entries are three rows apart
'we can use the offset function in the loop to choose
'the correct entry. This is also flexible enough
'such that if you ever wanted three or more entries
'per sheet, it will work.
rowCounter = 0
For Each itm In coll
wsDest.Range("B2").Offset(rowCounter * 3).Value = itm(0)
wsDest.Range("D2").Offset(rowCounter * 3).Value = itm(1)
wsDest.Range("B3").Offset(rowCounter * 3).Value = itm(2)
wsDest.Range("D3").Offset(rowCounter * 3).Value = itm(3)
'Increment rowcouter, looping around if you surpass
'two (or any future max number of items)
rowCounter = (rowCounter + 1) Mod 2
'If rowCounter has reset to 0, that means its time to
'print or whatever yuo need to do. Do it below
Debug.Print wsDest.Range("B2").Value
Debug.Print wsDest.Range("B5").Value
Next itm
'Here we check if rowcounter does not equal 0. This indicates
'that the loop ended with an odd number of elements, and should be
'printed out to flush that "buffer"
If rowCounter <> 0 Then
'Do final printout
Debug.Print wsDest.Range("B2").Value
Debug.Print wsDest.Range("B5").Value
End If
End Sub
Function GetUserInfo(rng As Range) As Collection
Dim c As Collection
Dim cel As Range
Dim a(0 To 3)
Set c = New Collection
For Each cel In rng
a(0) = cel.Value
a(1) = cel.Offset(, 1).Value
a(2) = cel.Offset(, 2).Value
a(3) = cel.Offset(, 3).Value
c.Add a
Next cel
'Return the collection
Set GetUserInfo = c
End Function
I'd manage it a bit differently. First, I don't think it's wise to ReDim an array in a loop. I'm not sure how efficiently VBA manages resizing arrays, but it can be an expensive process.
I'd store the relevant values from each row into a collection. The items in the collection will be an array with the relevant fields. This collection can then be looped over, with the data being dropped into the relevant fields (and then printed, or whatever needs to be done).
Let me know if this gets you started.
Sub RunIt()
Dim rng As Range
Dim lastRow As Long
Dim ws As Worksheet
Dim coll As Collection
Dim wsDest As Worksheet
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set wsDest = Sheets("Sheet2")
Set rng = Range("A2:A" & lastRow)
Set coll = GetUserInfo(rng)
For Each itm In coll
wsDest.Range("B2").Value = itm(0)
wsDest.Range("D2").Value = itm(1)
wsDest.Range("B3").Value = itm(2)
wsDest.Range("D3").Value = itm(3)
'Maybe do your print routine here, and then reload
Next itm
End Sub
Function GetUserInfo(rng As Range) As Collection
Dim c As Collection
Dim cel As Range
Dim a(0 To 3)
Set c = New Collection
For Each cel In rng
a(0) = cel.Value
a(1) = cel.Offset(, 1).Value
a(2) = cel.Offset(, 2).Value
a(3) = cel.Offset(, 3).Value
c.Add a
Next cel
'Return the collection
Set GetUserInfo = c
End Function
I'm looking to have a macro that, when run, will look for matches in two columns (column M on the DISPLAY sheet and column A on the REPORT_DOWNLOAD sheet), and then when there's a match copy the adjacent 3 cells on the REPORT_DOWNLOAD sheet (cells B, C & D) and paste them in cells S, T & U respectively of the DISPLAY sheet.
There will only be one match for each cell. I've tried to work off some previous vba code that was looking for multiple instances of each match, but I think I've confused myself too much at this point :(
Any help would be greatly appreciated.
Sub Display()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("DISPLAY")
Set ws2 = ThisWorkbook.Sheets("REPORT_DOWNLOAD")
Dim arr_1 As Variant, arr_2 As Variant, arr_result As Variant
arr_1 = ws1.Range("K2:K" & ws2.Range("D" & ws2.Rows.Count).End(xlUp).Row).Value2
arr_2 = ws2.Range("A2:L" & ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row).Value2
ReDim arr_result(LBound(arr_2) To UBound(arr_2), 1 To 3)
Dim i As Long, j As Long
For i = LBound(arr_1, 1) To UBound(arr_1, 1)
For j = LBound(arr_2, 1) To UBound(arr_2, 1)
If arr_1(i, 1) = arr_2(j, 1) Then
arr_result(i, 1) = arr_2(j, 6)
arr_result(i, 2) = arr_2(j, 7)
arr_result(i, 3) = arr_2(j, 8)
End If
Next j
Next i
ws1.Cells(2, 17).Resize(UBound(arr_result, 1), 3).Value2 = arr_result
End Sub
This is usually done like this:
Sub updateDisplayList()
Rem Just define work sheets:
Dim wsSource As Worksheet: Set wsSource = Worksheets("REPORT_DOWNLOAD")
Dim wsTarget As Worksheet: Set wsTarget = Worksheets("DISPLAY")
Rem
Dim rSearch As Range, rWhat As Range, rBase As Range, oCell As Range
Dim vVar As Variant
Rem Column A of source sheet:
Set rSearch = Application.Intersect(wsSource.UsedRange, wsSource.Columns(1)).Offset(1, 0)
Rem 3 first cells in columns which will be copied
Set rBase = wsSource.Range("B1:D1")
Rem Range with data to search: used part of column M
Set rWhat = Application.Intersect(wsTarget.UsedRange, wsTarget.Range("M:M"))
For Each oCell In rWhat
If Not IsEmpty(oCell) Then
vVar = Application.Match(oCell.Value, rSearch, 0)
If Not IsError(vVar) Then
rBase.Offset(vVar, 0).Copy Destination:=oCell.Offset(0, 6)
Rem If you want to clear target cells when value not found in source sheet:
Else
oCell.Offset(0, 6).Resize(1, 3).ClearContents
End If
End If
Next oCell
End Sub
(Not sure about column M - in your code you use values of column K)
I have a workbook that contains several sheets of data that I have combined. I removed some unnecessary sheets and cells (that are colour filled) and removed blanks (code sample below). I now have one work sheet with dates as headers and item numbers (col length vary).
I need to condense this again. I need two columns, columns A and B, B for every item number pulled back from the sheet and the Col A needs to be the header name of the column the item number was pulled from. The amount of columns will extend over time as more dates are added.
I just don't know where to go from here... The script is basic 'and then' I have quality checked it and it works up to this point.
Worksheets.Add Sheets(1)
ActiveSheet.Name = "Combined"
For i = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If i > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(i).Activate
ActiveSheet.UsedRange.Copy xRg
Next i
Sheets("Data").Delete
For Each ws In Worksheets
If ws.Name <> "Combined" Then
ws.Visible = xlSheetHidden
End If
Next ws
I then have a box pop up to delete specific coloured cells and end with this:
Columns("A:MK").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
I can copy column values over, after the above, to a new sheet but then adding header values based on the last cell in that column reaches my limitations of VBA.
I can't see that this has been asked and answered previously, any ideas?
Try this code
Sub Test()
Dim a, ws As Worksheet, sh As Worksheet, i As Long, j As Long, k As Long
Set ws = ThisWorkbook.Worksheets("Combined")
Set sh = ThisWorkbook.Worksheets("Condensed")
a = ws.Range("A1").CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 2)
For j = LBound(a, 2) To UBound(a, 2)
For i = 2 To UBound(a)
k = k + 1
b(k, 1) = a(1, j)
b(k, 2) = a(i, j)
Next i
Next j
With sh.Range("A1")
.Resize(1, 2).Value = Array("Header1", "Header2")
.Offset(1).Resize(k, UBound(b, 2)).Value = b
End With
End Sub
you could use Dictionary object
assuming you want to condense data in a worksheet named "Condensed" already in place
Sub Condense()
Dim cel As Range
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets("Combined")
For Each cel In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
dict.Add cel.Value, .Range(cel.Offset(1), cel.End(xlDown)).Value
Next
End With
Dim key As Variant
With Worksheets("Condensed")
For Each key In dict.keys
With .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(dict(key)))
.Value = key
.Offset(, 1) = dict(key)
End With
Next
End With
End Sub
I've been trying to search for days already for solutions or idea how to do this in Excel VBA, however I cannot find a similar scenario for my needs.
Here's the idea:
I have the following table as reference for the hyperlinks:
Now on a separate column, I want to create a "+" shape in each corresponding next column of the reference number and make each shape a hyperlink in reference to the first image provided. It may contain one or more shapes in one cell until all the links for that reference number has been made.
I want to do this in VBA because multiple links in single cell is not possible in Excel and hence shape/image/symbol hyperlinking is the only solution I can think of. I am clueless where to start or how to start.
I hope someone will be able to direct me as I am still learning on Excel VBA. Thank you in advance.
Set reference Microsoft Scripting Runtime
Sub SetHyperlinkOnShape()
' reference Microsoft Scripting Runtime
Dim ws As Worksheet, ws2 As Worksheet, dict As dictionary
Dim tKey(0) As Variant
Dim LRandomNumber As Integer
Set ws = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Application.ScreenUpdating = False
DeleteAllShapes ws2
Dim hyperLinkedShape As Shape
Dim t As Range
ColumnToPasteNumber = 2 ' on Sheet2 Column B
ColumnAlpha = "A" ' Column Latter from SHeet1 in your case H
LastRow = ws.Cells(ws.Rows.Count, ColumnAlpha).End(xlUp).Row ' get last row
Set dict = CreateObject("Scripting.Dictionary") ' put all unique value to dictionary
Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 2))
For ci = 1 To LastRow ' change 1 to 2 in your case to start from second row as you have headers
strName = Rng(ci, 1)
strLink = Rng(ci, 2)
If dict.Exists(strName) Then
Dim tempArr() As Variant
tempArr() = dict(strName)
sCount = UBound(tempArr) + 1
ReDim Preserve tempArr(0 To sCount)
tempArr(sCount) = strLink
dict(strName) = tempArr
Else
tKey(0) = strLink
dict.Add strName, tKey
End If
Next ci
For Each UniqueVal In dict ' loop dictionary to paste to cells
i = i + 1
Set t = ws2.Range(ws2.Cells(i, ColumnToPasteNumber), ws2.Cells(i, ColumnToPasteNumber))
NumbersOfPluses = UBound(dict(UniqueVal)) + 1
sw = t.Width / NumbersOfPluses
ws2.Cells(i, 1).Value = UniqueVal
For y = 1 To NumbersOfPluses ' set default shape width sw
sw = t.Height 'in points
sL = t.Left + sw * (y - 1)
If y = 1 Then sL = t.Left
Set hyperLinkedShape = ws2.Shapes.AddShape(msoShapeMathPlus, sL, t.Top, sw, t.Height)
hyperLinkedShape.Placement = xlFreeFloating ' do not size and dont move
strLink = dict(UniqueVal)(y - 1)
strHint = "Click ME"
ws2.Hyperlinks.Add Anchor:=hyperLinkedShape, Address:=strLink, SubAddress:="", ScreenTip:=strHint
Next y
If getMaxCellWidth < t.Height * NumbersOfPluses Then getMaxCellWidth = t.Height * NumbersOfPluses
Next UniqueVal
' ColumnWidth in units !!!
ws2.Columns("B:B").ColumnWidth = (((getMaxCellWidth) / 0.75 - 5) / 7) ' convert points to units
Application.ScreenUpdating = True
End Sub
Sub DeleteAllShapes(ws As Worksheet)
Dim shp As Shape
For Each shp In ws.Shapes
shp.Delete
Next shp
End Sub