I have Excel with data.
I wrote a code that allows me to filter data depending on the company.
Sub testProjectMl()
Dim sh As Worksheet, shDest As Worksheet, lastRow As Long, firstRow As Long, lastERowDest As Long
Dim i As Long, arrA, dictKP As Object
'Create a variable
Dim dictKS
Dim dictVT
Dim dictAK
Dim dictPP
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
firstRow = 8 'first row with data
arrA = sh.Range("A" & firstRow & ":A" & lastRow).Value 'place the range in an array for faster iteration
Set dictKP = CreateObject("Scripting.Dictionary")
Set dictKS = CreateObject("Scripting.Dictionary")
Set dictVT = CreateObject("Scripting.Dictionary")
Set dictPP = CreateObject("Scripting.Dictionary")
Set dictAK = CreateObject("Scripting.Dictionary")
With Sheets(ActiveSheet.Name)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 8 To lastRow
If IsNumeric(.Range("H" & i)) And Trim(.Range("H" & i).Value) <> "" And .Range("H" & i).Value <> 0 And .Range("H" & i).Value > 7000 Then
Select Case True
Case .Range("A" & i).Value Like "KP*"
dictKP.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "KS*"
dictKS.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "VT*"
dictVT.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "PP*"
dictPP.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "AK*"
dictAK.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
End Select
End If
Next i
End With
Sheets.Add.Name = "KP"
Sheets.Add.Name = "KS"
Sheets.Add.Name = "VT"
Sheets.Add.Name = "PP"
Sheets.Add.Name = "AK"
Set shDestKp = Sheets("KP")
Set shDestKs = Sheets("KS")
Set shDestVt = Sheets("VT")
Set shDestPp = Sheets("PP")
Set shDestAk = Sheets("AK")
For i = 0 To dictKP.Count - 1
lastERowDest = shDestKp.Range("A" & shDestKp.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictKP.items()(i).Copy shDestKp.Range("A" & lastERowDest)
shDestKp.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestKp.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestKp.Range("K" & lastERowDest).Copy ' copy the target format
shDestKp.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestKp.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestKp.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictKS.Count - 1
lastERowDest = shDestKs.Range("A" & shDestKs.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictKS.items()(i).Copy shDestKs.Range("A" & lastERowDest)
shDestKs.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestKs.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestKs.Range("K" & lastERowDest).Copy ' copy the target format
shDestKs.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestKs.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestKs.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictVT.Count - 1
lastERowDest = shDestVt.Range("A" & shDestVt.Rows.Count).End(xlUp).Row + 1
'If lastERowDest = 2 Then lastERowDest = 1
dictVT.items()(i).Copy shDestVt.Range("A" & lastERowDest)
shDestVt.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestVt.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestVt.Range("K" & lastERowDest).Copy ' copy the target format
shDestVt.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestVt.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestVt.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictPP.Count - 1
lastERowDest = shDestPp.Range("A" & shDestPp.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictPP.items()(i).Copy shDestPp.Range("A" & lastERowDest)
shDestPp.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestPp.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestPp.Range("K" & lastERowDest).Copy ' copy the target format
shDestPp.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestPp.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestPp.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictAK.Count - 1
lastERowDest = shDestAk.Range("A" & shDestAk.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictAK.items()(i).Copy shDestAk.Range("A" & lastERowDest)
shDestAk.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestAk.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestAk.Range("K" & lastERowDest).Copy ' copy the target format
shDestAk.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestAk.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestAk.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
End Sub
As you can see, depending on the value at the beginning of cell A, I adding the row in a certain dictionary. Then there is a cycle for each dictionary and inserting values into a specific sheets.
But I have a problem, for some reason the same line is entered in all the sheets when iterating through dictionaries.
For example (KS sheet):
This sheet should have the following value:
When Select Case and adding a row to the dictionary, the value in cell A is specified correctly and corresponds to a specific dictionary. BUT I don't understand why, when iterating through dictionaries, the same value from the dictKP dictionary is inserted.
Example what need in the end:
Please, try using the next code. It needs only a single dictionary, creating keys based on the first two company name characters. It will add new sheets based on the dictionary keys and clear the existing if they exist:
Sub testProjectMl()
Dim sh As Worksheet, newSh As Worksheet, lastRow As Long, firstRow As Long
Dim i As Long, arrA, minVal As Double, dict As Object
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.rows.count).End(xlUp).row
firstRow = 7 'the row where the headers exist
minVal = 7000 'you can change it (if another limit would be necessary)...
arrA = sh.Range("A" & firstRow & ":K" & lastRow).value
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrA) 'iterate between the array rows:
If IsNumeric(arrA(i, 8)) And Trim(arrA(i, 8)) <> "" And arrA(i, 8) <> 0 And arrA(i, 8) > minVal Then
If Not dict.Exists(left(arrA(i, 1), 2)) Then
dict.Add left(arrA(i, 1), 2), Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
Else
Set dict(left(arrA(i, 1), 2)) = Union(dict(left(arrA(i, 1), 2)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
End If
End If
Next i
'drop the dictionary items content in the appropriate sheet (add it if not existing):
Application.ScreenUpdating = False 'to make the code faster, when inserts sheet and copy ranges...
Application.EnableEvents = False
For i = 0 To dict.count - 1
If Not sheetExists(CStr(dict.Keys()(i))) Then
Set newSh = ActiveWorkbook.Sheets.Add(After:=sh) 'insert the sheet if it does not exist
newSh.name = dict.Keys()(i)
Else
Set newSh = ActiveWorkbook.Sheets(dict.Keys()(i))'set the existing sheet and clear its content
newSh.cells.ClearContents
End If
dict.items()(i).Copy newSh.Range("A1") 'copy the dictionary range
Next i
End Sub
Function sheetExists(shName As String) As Boolean
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.name = shName Then sheetExists = True: Exit Function
Next ws
End Function
Related
New user here who is also very new to Excel VB.
At the moment, I have a macro which does what you see here.
Essentially, I have 2 columns which can sometimes have cells which contain vertically stacked lines of data in each cell. Each of those lines is split out and put into newly inserted rows below (one line of data in the cell per row).
The problem I am having now, is that while the new rows now contain data in the two columns which had to be split (34 and 35), the remaining cells are empty. I am having trouble bringing the remaining 38 columns down into the newly-created rows. You can see what I mean in the image I posted. Two new rows were created and I need to fill them with the content of row 1 (fill in to the shaded area).
Here is my code right now. The part that is commented out is me trying to fill the empty space. The un-commented code does what you see in the image.
Sub main()
Dim iRow As Long, nRows As Long, nData As Long
Dim IDVariables As Range
Dim arr As Variant
With Worksheets("UI").Columns("AH")
nRows = .Cells(.Rows.Count, 1).End(xlUp).Row
For iRow = nRows To 2 Step -1
With .Cells(iRow)
arr = Split(.Value, vbLf)
nData = UBound(arr) + 1
If nData > 1 Then
.EntireRow.Offset(1).Resize(nData - 1).Insert
.Resize(nData).Value = Application.Transpose(arr)
.Offset(, 1).Resize(nData).Value = Application.Transpose(Split(.Offset(, 1).Value, vbLf))
'Set IDVariables = Range("A" & iRow & ":AG" & iRow)
'IDVariables.Select
'Selection.Copy
'Range("A" & (iRow + 1) & ":A" & (iRow + nData -1)).Select
'Selection.Paste
End If
End With
Next iRow
End With
End Sub
Any help would be very much appreciated.
Thanks!
Tested and working fine....
Option Explicit
Sub ReCode()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LR As Long, i As Long, arr
LR = ws.Range("AH" & ws.Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
If InStr(ws.Range("AH" & i), vbLf) Then
ws.Range("A" & i + 1).EntireRow.Insert xlUp
ws.Range("A" & i).EntireRow.Copy ws.Range("A" & i + 1)
arr = Split(ws.Range("AH" & i), vbLf)
ws.Range("AH" & i) = arr(0)
ws.Range("AH" & i + 1) = arr(1)
arr = ""
End If
Next i
End Sub
I'm late doing this but I figured it out. I'll post my solution for anyone who has a similar problem.
Sub main()
Dim iRow As Long, nRows As Long, nData As Long
Dim arr As Variant
Dim IDVariables, Comments, AllocationCheck As Range
Application.ScreenUpdating = False
With Worksheets("PRM2_Computer").Columns("AH")
nRows = .Cells(.Rows.Count, 1).End(xlUp).Row
For iRow = nRows To 2 Step -1
With .Cells(iRow)
arr = Split(.Value, vbLf)
nData = UBound(arr) + 1
If nData = 1 Then
Range("AI" & iRow) = 1
Range("AK" & iRow) = "Single Industry"
End If
If nData > 1 Then
.EntireRow.Offset(1).Resize(nData - 1).Insert
.Resize(nData).Value = Application.Transpose(arr)
.Offset(, 1).Resize(nData).Value = Application.Transpose(Split(.Offset(, 1).Value, vbLf))
.Offset(, 2).Resize(nData).Value = Application.Transpose(Split(.Offset(, 2).Value, vbLf))
Set Comments = Range("AL" & iRow & ":AM" & iRow)
Comments.Copy Range("AL" & (iRow + 1) & ":AL" & (iRow + nData - 1))
Set AllocationCheck = Range("AK" & (iRow) & ":AK" & (iRow + nData - 1))
AllocationCheck.Value = Application.Sum(Range("AI" & iRow & ":AI" & (iRow + nData - 1)))
Set IDVariables = Range("A" & iRow & ":AG" & iRow)
IDVariables.Copy Range("A" & (iRow + 1) & ":A" & (iRow + nData - 1))
End If
End With
Next iRow
End With
End Sub
So I have an macro for a file in which there are three columns. The macro detect specific columns and rows in another workbook for my three columned file. See image below for workbook 1.
Then it should look at the rows and columns of workbook 2 (see below) and find the position of column A and B that match from workbook 1 and paste in the corresponding value of column C into workbook 2 (the value 1). However I keep getting #VALUE! error and I don't know why its happening.
FYI - the columns continue to 51 but cant fit in the image
Below is the code for this macro:
Sub Location()
Dim i As Long, k As Long, ws1 As Worksheet, ws2 As Worksheet
Dim lastrow As Long
Set ws1 = Workbooks("Book3.xlsm").Worksheets("Sheet1")
Set ws2 = Workbooks("Book4.xlsm").Worksheets("Sheet1")
lastrow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
For i = 2 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
For k = 2 To ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
ws2.Cells(i, k).Value = ws2.Evaluate("IFERROR(INDEX(" & ws1.Range("B1:B" & lastrow).Address(0, 0, xlA1, 1) & ",AGGREGATE(15,6,ROW(" & ws1.Range("A1:A" & lastrow).Address(0, 0, xlA1, 1) & ")" & _
"/((" & ws1.Range("A1:A" & lastrow).Address(0, 0, xlA1, 1) & " = " & ws2.Cells(i, 1).Address(0, 0) & ")*(" & ws1.Range("C1:C" & lastrow).Address(0, 0, xlA1, 1) & "=" & _
ws2.Cells(1, k).Address(0, 0) & ")),1)),"""")")
Next k
Next i
End Sub
Any help? Thanks.
I should have thought of this formula first:
Sub Location()
Dim i As Long, k As Long, ws1 As Worksheet, ws2 As Worksheet
Dim LastRow As Long
Set ws1 = Workbooks("Book3.xlsm").Worksheets("Sheet1")
Set ws2 = Workbooks("Book4.xlsm").Worksheets("Sheet1")
LastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
For i = 2 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
For k = 2 To ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
ws2.Cells(i, k).Value = Application.WorksheetFunction.SumIfs(ws1.Range("C1:C" & LastRow), ws1.Range("A1:A" & LastRow), ws2.Cells(i, 1), ws1.Range("B1:B" & LastRow), ws2.Cells(1, k))
If ws2.Cells(i, k).Value = 0 Then ws2.Cells(i, k).Value = ""
Next k
Next i
End Sub
I have the below code which searches for specific text based on the Col header, like Col O, Col P etc. Instead I want to search using the respective column name in Row 1.
I have added the column name in the code comments.
Sub PassFailValidationandupdatecomments()
Dim Rng As Range, cl As Range
Dim LastRow As Long, MatchRow As Variant
With Sheets("DRG")
LastRow = .Cells(.Rows.count, "E").End(xlUp).Row '"E" - Live ASIN
Set Rng = .Range("E2:E" & LastRow) ' "E" - Live ASIN
End With
With Sheets("Latency")
For Each cl In .Range("B2:B" & .Cells(.Rows.count, "B").End(xlUp).Row) ` "B" - ASIN
MatchRow = Application.Match(cl.Value, Rng, 0)
If Not IsError(MatchRow) Then
Select Case Sheets("DRG").Range("AH" & MatchRow + 1).Value ' "AH" - Final Test Result
.Range("O" & cl.Row).Value = "Pass" '"O" - Pass/Fail
Case "Pended"
.Range("O" & cl.Row).Value = "Fail"'"O" - Pass/Fail
Case "In progress"
.Range("O" & cl.Row).Value = "In progress"'"O" - Pass/Fail End Select
If Not Sheets("DRG").Range("E" & MatchRow + 1).Value = vbNullString Then .Range("P" & cl.Row).Value = .Range("P" & cl.Row).Value & IIf(Not .Range("P" & cl.Row).Value = vbNullString, ";", "") & Sheets("DRG").Range("S" & MatchRow + 1).Value ' "E" - Live ASIN ; "P" - Comments ; "S" - App Trail
End If
Next cl
End With
This is a follow on from How do I get all the different unique combinations of 3 columns using VBA in Excel?
It almost what i need, however, my requirements is that it sums the third column which will contain figures instead of yes/no
Sub sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim col As New Collection
Dim Itm
Dim cField As String
Const deLim As String = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
cField = .Range("A" & i).Value & deLim & _
.Range("B" & i).Value & deLim & _
.Range("C" & i).Value
On Error Resume Next
col.Add cField, CStr(cField)
On Error GoTo 0
Next i
i = 2
.Range("A1:C1").Copy .Range("F1")
.Range("I1").Value = "Count"
For Each Itm In col
.Range("F" & i).Value = Split(Itm, deLim)(0)
.Range("G" & i).Value = Split(Itm, deLim)(1)
.Range("H" & i).Value = Split(Itm, deLim)(2)
For j = 2 To lRow
cField = .Range("A" & j).Value & deLim & _
.Range("B" & j).Value & deLim & _
.Range("C" & j).Value
If Itm = cField Then nCount = nCount + 1
Next
.Range("I" & i).Value = nCount
i = i + 1
nCount = 0
Next Itm
End With
End Sub
This code was originally added by
Siddharth Rout
try this (follows comments)
Option Explicit
Sub Main()
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = 4 To Range("A" & Rows.Count).End(xlUp).Row '<-- change 4 and "A" to your data actual upleftmost cell row and column
dict(cells(i, 1).Value & "|" & cells(i, 2).Value) = dict(cells(i, 1).Value & "|" & cells(i, 2).Value) + cells(i, 3).Value '<--| change 3 to your actual "column to sum up" index
Next
With Range("G3").Resize(dict.Count) '<-- change "G3" to your actual upleftmost cell to start writing output data from
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items) '<--| change 2 to your actual column offset where to start writing summed values form
End With
End Sub
The codes below are edited by me to get the results but unlucky to get it. I am trying to compare sheet1 Col A&B with sheet2 Col A&B and result on sheet3. Kindly advise.
Sub ReconcileRegisters()
Dim i As Long, _
LRa As Long, _
LRb As Long, _
rowx As Long
LRa = Sheets("sheet1").Range("A1:B" & Rows.Count).End(xlUp).Row
LRb = Sheets("sheet2").Range("A1:B" & Rows.Count).End(xlUp).Row
rowx = 2
Application.ScreenUpdating = False
For i = 2 To LRa
If IsError(Application.Match(Sheets("sheet1").Range("A1:B" & i).Value, Sheets("sheet2").Range("A1:B" & LRb), 0)) Then
Sheets("sheet3").Range("A" & rowx).Value = Sheets("sheet1").Range("A1:B" & i).Value
rowx = rowx + 1
End If
Next i
For i = 2 To LRb
If IsError(Application.Match(Sheets("sheet2").Range("A1:B" & i).Value, Sheets("sheet1").Range("A1:B" & LRa), 0)) Then
Sheets("sheet3").Range("A" & rowx).Value = Range("A1:B" & i).Value
rowx = rowx + 1
End If
Next i
Application.ScreenUpdating = True
MsgBox "Matching process is complete"
End Sub
If you compare both loops then I would assume that you need Sheets("sheet2") in this second section:
Sheets("sheet3").Range("A" & rowx).Value = Range("A1:B" & i).Value