I am using the following VBA to concatenate rows with a common ID
Function JoinAll(ByVal BaseValue, ByRef rng As Range, ByVal delim As String)
Dim a, i As Long
a = rng.Value
For i = 1 To UBound(a, 1)
If a(i, 1) = BaseValue Then JoinAll = JoinAll & _
IIf(JoinAll = "", "", delim) & a(i, 3)
Next
End Function
As an example:
ID | Date | Purchase | Concat Value
1 | 3/4/16 | Car | Car, Cap
2 | 5/2/12 | Cat | Cat
1 | 6/2/13 | Cap | Cap
When run, this creates Car, Cap.
However, this is a table with a filter, and once it is filtered to this:
ID | Date | Purchase | Concat Value
1 | 3/4/16 | Car | Car, Cap
2 | 5/2/12 | Cat | Cat
It still shows Car, Cap instead of ignoring that Cap is not visible.
I have seen this answer, but don't see how to make it work with my current VBA:
Excel VBA Concatenate only visible cells of filtered column. Test code included
UPDATE:
Using this I am getting only the visible items joined, but I need it to return the values in column 3. This only returns the values in column 1:
Function JoinAll(ByVal BaseValue, ByRef rng As Range, ByVal delim As String)
For Each a In rng
If a = BaseValue And a.EntireRow.Hidden = False Then
JoinAll = JoinAll & IIf(JoinAll = "", "", delim) & a
End If
Next a
End Function
This works. There is a typo/bug in your original code as a=rng.value, so a should be rng when considering the hidden rows.
Function JoinAll3(ByVal BaseValue, ByRef rng As Range, ByVal delim As String)
Dim a, i As Long
a = rng.Value
For i = 1 To UBound(a, 1)
If a(i, 1) = BaseValue And rng(i, 1).EntireRow.Hidden = False Then
JoinAll3 = JoinAll3 & IIf(JoinAll3 = "", "", delim) & a(i, 3)
End If
Next
End Function
Have you tried something like:
For each val in rng.Columns(3).Cells
If val = BaseValue And val.EntireRow.Hidden = False Then
JoinAll = JoinAll & IIf(JoinAll = "", "", delim) & val
End If
Next val
Related
Since I am new to VBA excel, I don’t have a clue of how to tackle the following issue.
I have created a user entry form with which users can enter project details. Whenever project details need to be updated, this user entry form can be used.
These entries will be stored in another sheet called “Project Update History”. This list contains all the update entries for every project (as shown in the table below).
/--------------------------------------------------------------\
| | EntryDate | Project Name | Project ID | Status |
|--------------------------------------------------------------|
| 1 | 01.02.2018 | ABC | P001 | text |
|--------------------------------------------------------------|
| 2 | 01.02.2018 | CDE | P002 | text |
|--------------------------------------------------------------|
| 3 | 15.02.2018 | CDE | P002 | text |
|--------------------------------------------------------------|
| 4 | 16.02.2018 | FGH | P003 | text |
|--------------------------------------------------------------|
| 5 | 08.08.2018 | ABC | P001 | text |
|--------------------------------------------------------------|
| 6 | 09.09.2019 | FGH | P003 | text |
|--------------------------------------------------------------|
| 7 | 14.09.2019 | FGH | P003 | text |
|--------------------------------------------------------------|
| 8 | 12.12.2019 | CDE | P002 | text |
\--------------------------------------------------------------/
enter image description here
As you can imagine, there are hundreds of entries and it’s quite difficult to get an overview. Ideally, there is a list in a separate sheet with latest project status only. (see table below)
/--------------------------------------------------------------\
| | EntryDate | Project Name | Project ID | Status |
|--------------------------------------------------------------|
| 1 | 08.08.2018 | ABC | P001 | text |
|--------------------------------------------------------------|
| 2 | 14.09.2019 | FGH | P003 | text |
|--------------------------------------------------------------|
| 3 | 12.12.2019 | CDE | P002 | text |
\--------------------------------------------------------------/
enter image description here
In order to get this, I already tried different options such as using “filters” or “array formulas”. However, both were rather dissatisfactory.
Filters were not really helpful, as I want to see all the projects at once (but just the most recent project updates).
Array formulas actually gave me the output, I wanted … but the excel file became very slow.
(To get the latest entry date {=MAX(IF(‘Project Update History’!C:C=C4,’Project Statuses’!B:B,0))}
(To get the corresponding entry details an INDEX Match formula.)
So the only way, I could avoid this problem is to use macros. My idea is to have a button that will search for the latest status of each project and display in a sheet… but I really don’t know how to code this… Maybe someone else has also encountered this issue and found a solution for it? I would really apprecitate any help from you. :)
Many thanks in advance for your help.
Niro
Here is one way using arrays. Depending on the size of your data you may hit a limit with Transpose, in which case I can re-write part of the solution.
I have used "," delimiter to keep track of separate column items when concatenating together.You may wish to swop this with a symbol you do not expect to find in your data to ensure you do not end up with unexpected results.
Change the value here, Const DELIMITER As String = "," , if changing the delimiter.
Option Explicit
Public Sub GetLastDateInfo()
Application.ScreenUpdating = False
Const DELIMITER As String = ","
Dim arr(), resultsArr(), dict As Object, i As Long, currDate As Long, ws As Worksheet, headers()
headers = Array("Entry Date", "Project Date", "Project ID", "Status")
Set ws = ThisWorkbook.Worksheets("Sheet1"): Set dict = CreateObject("Scripting.Dictionary")
arr = ws.Range("A2:D" & GetLastRow(ws, 1)).Value
ReDim resultsArr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
For i = LBound(arr, 1) To UBound(arr, 1)
currDate = CLng(CDate(Replace$(arr(i, 1), ".", "-")))
If Not dict.Exists(arr(i, 2) & DELIMITER & arr(i, 3)) Then
dict.Add arr(i, 2) & DELIMITER & arr(i, 3), currDate & DELIMITER & arr(i, 4)
ElseIf Split(dict(arr(i, 2) & DELIMITER & arr(i, 3)), DELIMITER)(0) < currDate Then
dict(arr(i, 2) & DELIMITER & arr(i, 3)) = currDate & DELIMITER & arr(i, 4)
End If
Next i
Dim key As Variant, r As Long, tempArr() As String
For Each key In dict.keys
r = r + 1
tempArr = Split(dict(key), DELIMITER)
resultsArr(r, 1) = tempArr(0)
resultsArr(r, 4) = tempArr(1)
tempArr = Split(key, DELIMITER)
resultsArr(r, 2) = tempArr(0)
resultsArr(r, 3) = tempArr(1)
Next key
resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
ReDim Preserve resultsArr(1 To UBound(resultsArr, 1), 1 To r)
resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
With Worksheets("Sheet2")
.Range("A1").Resize(1, UBound(headers) + 1) = headers
.Range("A2").Resize(UBound(resultsArr, 1), UBound(resultsArr, 2)) = resultsArr
End With
Application.ScreenUpdating = True
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
Output:
Adapted for increased number of columns ( uses GetLastRow function from above):
Public Sub GetLastDateInfo2()
Application.ScreenUpdating = False
Const DELIMITER As String = ","
Dim arr(), resultsArr(), dict As Object, dict2 As Object, i As Long, j As Long
Dim currDate As Long, ws As Worksheet, headers()
Set ws = ThisWorkbook.Worksheets("Sheet1")
headers = ws.Range("A1:AN1").Value
headers = Application.WorksheetFunction.Index(headers, 1, 0)
Set dict = CreateObject("Scripting.Dictionary"): Set dict2 = CreateObject("Scripting.Dictionary")
arr = ws.Range("A2:AN" & GetLastRow(ws, 1)).Value
ReDim resultsArr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
For i = LBound(arr, 1) To UBound(arr, 1)
currDate = CLng(CDate(Replace(arr(i, 1), ".", "-")))
If Not dict.Exists(arr(i, 2) & DELIMITER & arr(i, 3)) Then
dict.Add arr(i, 2) & DELIMITER & arr(i, 3), currDate
dict2.Add arr(i, 2) & DELIMITER & arr(i, 3), arr(i, 4)
For j = 5 To UBound(arr, 2)
dict2(arr(i, 2) & DELIMITER & arr(i, 3)) = dict2(arr(i, 2) & DELIMITER & arr(i, 3)) & DELIMITER & arr(i, j)
Next j
ElseIf Split(dict(arr(i, 2) & DELIMITER & arr(i, 3)), DELIMITER)(0) < currDate Then
dict(arr(i, 2) & DELIMITER & arr(i, 3)) = currDate
dict2(arr(i, 2) & DELIMITER & arr(i, 3)) = vbNullString
For j = 4 To UBound(arr, 2)
dict2(arr(i, 2) & DELIMITER & arr(i, 3)) = dict2(arr(i, 2) & DELIMITER & arr(i, 3)) & DELIMITER & arr(i, j)
Next j
End If
Next i
Dim key As Variant, r As Long, tempArr() As String
For Each key In dict.keys
r = r + 1
tempArr = Split(dict(key), DELIMITER)
resultsArr(r, 1) = tempArr(0)
tempArr = Split(key, DELIMITER)
resultsArr(r, 2) = tempArr(0)
resultsArr(r, 3) = tempArr(1)
resultsArr(r, 4) = Replace$(dict2(key), DELIMITER, vbNullString, , 1)
Next key
resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
ReDim Preserve resultsArr(1 To UBound(resultsArr, 1), 1 To r)
resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
Application.DisplayAlerts = False
With Worksheets("Sheet2")
.UsedRange.ClearContents
.Range("A2").Resize(UBound(resultsArr, 1), UBound(resultsArr, 2)) = resultsArr
.Columns("D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote,Other:=True, OtherChar _
:=DELIMITER, TrailingMinusNumbers:=True
.Range("A1").Resize(1, UBound(headers)) = headers
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have a code that I am having trouble running on excel 2013. 2010 works fine.
I've been contemplating just doing formulas because I cannot get this to work.
Here is the logic
Only fill values in sheet X if this condition exists: In Sheet A , If column a = value 1 , value 2, or value 3
and column b <> value 4, <> value 5
Then lookup headers from sheet X into sheet Y. These headers will be in sheet Y column c.
for the headers that are matched to sheet Y col c, find like data of sheet X. column c, and sheet Y. column d. Going to use these as lookup for next column in sheet Y. For where there are mismatches use 'OTHERS' as value.
for matched headers/columns return sheet Y column e (value) and multiply by sheet X. column d. minus one.
return all these values to sheet a where the headers are like.
Sheet X (below formulas in stack and overflow cols would actually be calculated)
+-------------+-------------+------------+-------+-----------------+-------------+
| conditions | condition 2 | currency | value | stack | overflow |
+-------------+-------------+------------+-------+-----------------+-------------+
| value 1 | value 10 | USD | 100 | 100 * (.75 - 1) | |
| value 2 | value 7 | XRP | 200 | 200 * (.50 - 1) | |
| value 3 | value 8 | USD | 300 | | 300*(.65-1) |
| value 1 | value 9 | XRP | 400 | | 400*(.24-1) |
+-------------+-------------+------------+-------+-----------------+-------------+
Sheet Y
+----------+----------+--------+
| header | currency | value |
+----------+----------+--------+
| stack | USD | .75 |
| stack | OTHER | .50 |
| overflow | USD | .65 |
| overflow | OTHER | .24 |
+----------+----------+--------+
This code gets slow at the for loop at the bottom of the code.
Here is my code:
Public Sub calc()
Application.ScreenUpdating = False
Dim i As Long, thisScen As Long, nRows As Long, nCols As Long
Dim stressWS As Worksheet
Set stressWS = Worksheets("EQ_Shocks")
Unprotect_Tab ("EQ_Shocks")
nRows = lastWSrow(stressWS)
nCols = lastWScol(stressWS)
Dim readcols() As Long
ReDim readcols(1 To nCols)
For i = 1 To nCols
readcols(i) = i
Next i
Dim eqShocks() As Variant
eqShocks = colsFromWStoArr(stressWS, readcols, False)
'read in database columns
Dim dataWs As Worksheet
Set dataWs = Worksheets("database")
nRows = lastrow(dataWs)
nCols = lastCol(dataWs)
Dim dataCols() As Variant
Dim riskSourceCol As Long
riskSourceCol = getWScolNum("condition 2", dataWs)
ReDim readcols(1 To 4)
readcols(1) = getWScolNum("value", dataWs)
readcols(2) = getWScolNum("currency", dataWs)
readcols(3) = getWScolNum("condition", dataWs)
readcols(4) = riskSourceCol
dataCols = colsFromWStoArr(dataWs, readcols, True)
'read in scenario mappings
Dim mappingWS As Worksheet
Set mappingWS = Worksheets("mapping_ScenNames")
Dim stressScenMapping() As Variant
ReDim readcols(1 To 2): readcols(1) = 1: readcols(2) = 2
stressScenMapping = colsFromWStoArr(mappingWS, readcols, False, 2) 'include two extra columns to hold column number for IR and CR shocks
For i = 1 To UBound(stressScenMapping, 1)
stressScenMapping(i, 3) = getWScolNum(stressScenMapping(i, 2), dataWs)
If stressScenMapping(i, 2) <> "NA" And stressScenMapping(i, 3) = 0 Then
MsgBox ("Could not find " & stressScenMapping(i, 2) & " column in database")
Exit Sub
End If
Next i
ReDim readcols(1 To 4): readcols(1) = 1: readcols(2) = 2: readcols(3) = 3: readcols(4) = 4
stressScenMapping = filterOut(stressScenMapping, 2, "NA", readcols)
'calculate stress and write to database
Dim thisEqShocks() As Variant
Dim keepcols() As Long
ReDim keepcols(1 To UBound(eqShocks, 2))
For i = 1 To UBound(keepcols)
keepcols(i) = i
Next i
Dim thisCurrRow As Long
For thisScen = 1 To UBound(stressScenMapping, 1)
thisEqShocks = filterIn(eqShocks, 2, stressScenMapping(thisScen, 1), keepcols)
If thisEqShocks(1, 1) = "#EMPTY" Then
For i = 2 To nRows
If dataCols(i, 4) <> "value 4" And dataCols(i, 4) <> "value 5" And (dataCols(i, 1) = "value 1" Or dataCols(i, 1) = "value 2") Then
dataWs.Cells(i, stressScenMapping(thisScen, 3)).value = "No shock found"
End If
Next i
Else 'calculate shocks
Call quicksort(thisEqShocks, 3, 1, UBound(thisEqShocks, 1))
For i = 2 To nRows
If dataCols(i, 4) <> "value 5" And dataCols(i, 4) <> "value 6" And (dataCols(i, 1) = "value 1" Or dataCols(i, 1) = "value 2" Or dataCols(i, 1) = "value 3") Then
thisCurrRow = findInArrCol(dataCols(i, 3), 3, thisEqShocks)
If thisCurrRow = 0 Then 'could not find currency so use generic shock
thisCurrRow = findInArrCol("OTHERS", 3, thisEqShocks)
End If
If thisCurrRow = 0 Then
dataWs.Cells(i, stressScenMapping(thisScen, 3)).value = "No shock found"
Else
dataWs.Cells(i, stressScenMapping(thisScen, 3)).value = Replace(dataCols(i, 2), "-", 0) * (thisEqShocks(thisCurrRow, 4) - 1)
End If
End If
Next i
End If
Next thisScen
Application.ScreenUpdating = True
End Sub
I read a rubber duck post and was inspired to turn this from script like code into code like code. (i have use type instead of private pVar sorry ducky for failing you in this one LOL) My comment below still stands though. I tested on 5000 cells and this coded executed in under a second on average.
INSIDE THIS WORKBOOK:
Option Explicit
Sub main()
Dim startTime As Long
startTime = Tests.GetTickCount
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim lastRow As Integer
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A4:A" & lastRow), Order:=xlAscending
.SortFields.Add Key:=Range("B4:B" & lastRow), Order:=xlAscending
.Header = xlYes
.SetRange Range("A4:F" & lastRow)
.Apply
End With
Dim colOfItems As Collection
Set colOfItems = New Collection
Dim cell As Range
For Each cell In ws.Range("A4:A" & lastRow)
Dim item As Items
If cell.value <> 1 And cell.value <> 2 And cell.value <> 3 Then
Exit For
Else
Set item = Factories.newItem(ws, cell.row)
colOfItems.Add item
Set item = Nothing
End If
Next cell
Set ws = Nothing
Dim wsTwo As Worksheet
Set wsTwo = Sheets("Sheet2")
Dim row As Integer
row = 4
Dim itemcheck As Items
For Each itemcheck In colOfItems
If Tests.conditionTwoPass(itemcheck) Then
With wsTwo
.Range("A" & row) = itemcheck.conditionOne
.Range("B" & row) = itemcheck.conditionTwo
.Range("C" & row) = itemcheck.CurrencyType
.Range("D" & row) = itemcheck.ValueAmount
.Range("E" & row) = itemcheck.Stack
.Range("F" & row) = itemcheck.OverFlow
End With
row = row + 1
End If
Next itemcheck
Dim endTime As Long
endTime = Tests.GetTickCount
Debug.Print endTime - startTime
End Sub
INSIDE MODULE NAMED FACTORIES:
Public Function newItem(ByRef ws As Worksheet, ByVal row As Integer) As Items
With New Items
.conditionOne = ws.Range("A" & row)
.conditionTwo = ws.Range("B" & row)
.CurrencyType = ws.Range("C" & row)
.ValueAmount = ws.Range("D" & row)
.Stack = ws.Range("E" & row)
.OverFlow = ws.Range("F" & row)
Set newItem = .self
End With
End Function
INSIDE MODULE NAMED TESTS:
Public Declare Function GetTickCount Lib "kernel32" () As Long
Function conditionTwoPass(ByVal itemcheck As Items) As Boolean
conditionTwoPass = False
If itemcheck.conditionTwo <> 4 And itemcheck.conditionTwo <> 5 Then
conditionTwoPass = True
End If
End Function
INSIDE CLASS MODULE NAMED ITEMS:
Private pConditionOne As Integer
Private pConditionTwo As Integer
Private pCurrencyType As String
Private pValueAmount As Integer
Private pStack As String
Private pOverflow As String
Public Property Let conditionOne(ByVal value As Integer)
pConditionOne = value
End Property
Public Property Get conditionOne() As Integer
conditionOne = pConditionOne
End Property
Public Property Let conditionTwo(ByVal value As Integer)
pConditionTwo = value
End Property
Public Property Get conditionTwo() As Integer
conditionTwo = pConditionTwo
End Property
Public Property Let CurrencyType(ByVal value As String)
If value = "USD" Then
pCurrencyType = value
Else
pCurrencyType = "OTHER"
End If
End Property
Public Property Get CurrencyType() As String
CurrencyType = pCurrencyType
End Property
Public Property Let ValueAmount(ByVal value As Integer)
pValueAmount = value
End Property
Public Property Get ValueAmount() As Integer
ValueAmount = pValueAmount
End Property
Public Property Let Stack(ByVal value As String)
pStack = value
End Property
Public Property Get Stack() As String
Stack = pStack
End Property
Public Property Let OverFlow(ByVal value As String)
pOverflow = value
End Property
Public Property Get OverFlow() As String
OverFlow = pOverflow
End Property
Public Property Get self() As Items
Set self = Me
End Property
Here is a formula only solution, using a helper column to lookup 2 criteria (header & column) at once:
Add a helper column in Sheet Y column E like shown below. Use the following formula in E:
=C:C&D:D
Use the following formula in E2 and copy it down and right:
=IF(AND(OR($A:$A="value 1",$A:$A="value 2",$A:$A="value 3"),$B:$B<>"value 4",$B:$B<>"value 5"),$D:$D*(IFNA(VLOOKUP(E$1&$C:$C,'Sheet Y'!$E:$F,2,FALSE),VLOOKUP(E$1&"OTHER",'Sheet Y'!$E:$F,2,FALSE))-1),"")
The calculation part of the formula
$D:$D*(IFNA(VLOOKUP(E$1&$C:$C,'Sheet Y'!$E:$F,2,FALSE),VLOOKUP(E$1&"OTHER",'Sheet Y'!$E:$F,2,FALSE))-1)
looks up a combination of "header" and column C in the helper column. If it finds the combination it returns its value if not it looks up a combination of "header" and "OTHER" and returns its value to perform the calculation.
The IF(AND(OR part is the condition of your point 1 in your question.
the loop gets slow because it's too much interaction between excel and VBA. Put the entire loop within the VBA , filling in the 2D array and dump the result out like so:
Sheets(1).cells(1,1).Resize(Ubound(arr2D),Ubound(arr2D,2)).value2 = arr2D
on the contrary, quicksort call is probably slow in VBA, so it may make sense to sort in Excel AFTER the array is pasted back to a sheet using native Range.Sort method.
I have 5 columns. Column C "Account" and column D "Person" are my data set.
I want to use VBA to look at how many rows of data I have and then fill that number of rows in 1) Column E "Concatenate" with a concatenate of "Account" and "Employee" fill that number of rows in 2) columns A and B with an INDEX-MATCH equation I have.
..I tried to draw out my columns below but it isn't formatting in the way I'd like it to be... sorry
Owner | Comment | Account | Employee | Concatenate
Jay | Done | JSMA1 | Sally | JSMA1 Sally
Will | Not Done| KLLM4 | Jack | KLLM4 Jack
Ken | Done | BM3R1 | Sam | BM3R1 Sam
Any ideas?
try this:
Option Explicit
Public Sub fillRanges()
Dim ur As Range, hdr As Range, conCol As Variant, lRow As Long
Dim ownCol As Variant, comCol As Variant
Dim actCol As Variant, empCol As Variant
Set ur = Sheet1.UsedRange ' minimal range
Set hdr = ur.Rows(1) ' header row
lRow = ur.Rows.Count ' last row
With Application
ownCol = .Match("Owner", hdr, 0)
comCol = .Match("Comment", hdr, 0)
actCol = .Match("Account", hdr, 0)
empCol = .Match("Employee", hdr, 0)
conCol = .Match("Concatenate", hdr, 0)
End With
If Not IsError(ownCol) And _
Not IsError(comCol) And _
Not IsError(actCol) And _
Not IsError(empCol) And _
Not IsError(conCol) _
Then
With ur
.Range(.Cells(2, ownCol), .Cells(lRow, ownCol)) = "INDEX-MATCH equation 1"
.Range(.Cells(2, comCol), .Cells(lRow, comCol)) = "INDEX-MATCH equation 2"
.Range(.Cells(2, conCol), .Cells(lRow, conCol)).Formula = _
"=INDIRECT(ADDRESS(ROW()," & actCol & ")) & "" "" & " & _
" INDIRECT(ADDRESS(ROW(), " & empCol & "))"
End With
End If
End Sub
I have 2 spreadsheets with the data below.
Name | System 1 | System 2 | System 3 |
John | x | x | |
James| | x | x |
Peter| | x | |
Name | Process A | Process B | Process C |
John | | x | |
James| x | | x |
Peter| x | | x |
Are there any ways in VBA I can do to merge these two lists in a matrix format as below?
| Process A | Process B | Process C |
System 1 | | John | |
System 2 | James, Peter | John | James, Peter |
System 3 | James | | James |
I have coding experience but not very strong in VBA. Appreciate if anyone can give me some code samples to start with.
There are 27 systems, 21 processes and 188 names. So, it will take sometime doing it manually.
Thank you.
Comments are in the code, HTH.
Option Explicit
Sub Main(): On Error GoTo errMain
Dim system As Range
Dim process As Range
' Select ranges of systems and processes
Set system = Application.InputBox( _
prompt:="Go to sheet with 'system' data and select it", Title:="S Y S T E M", Type:=8)
Set process = Application.InputBox( _
prompt:="Go to sheet with 'process' data and select it", Title:="P R O C E S S", Type:=8)
' Do the merge
MergeIt system, process
Exit Sub
errMain:
MsgBox Err.Description, vbCritical
End Sub
Private Sub MergeIt(system As Range, process As Range)
Dim processData As Range
Dim processColumn As Range
Dim processName As String
Dim processUsers As Variant
Dim processValues As Variant
Dim processIndex As Integer
Dim systemData As Range
Dim systemColumn As Range
Dim systemName As String
Dim systemUsers As Variant
Dim systemValues As Variant
Dim systemIndex As String
' Add new sheet where the merged data will be stored
Dim mergedSheet As Worksheet
Set mergedSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
mergedSheet.Name = "Merged" & _
Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now)
' Get process and system users as first column without the first cell
processUsers = process.Columns(1).Offset(1, 0).Resize(process.Rows.Count - 1, 1)
systemUsers = system.Columns(1).Offset(1, 0).Resize(system.Rows.Count - 1, 1)
' Get process and system data as all columns except the first one where the users are
Set processData = process.Offset(0, 1).Resize(process.Rows.Count, process.Columns.Count - 1)
Set systemData = system.Offset(0, 1).Resize(system.Rows.Count, system.Columns.Count - 1)
processIndex = 1
' Go the process data by columns.
' Add process name to result sheet and for each process column go through
' all system columns and do the merge
For Each processColumn In processData.Columns
processIndex = processIndex + 1
processName = processColumn.Cells(1).Value
mergedSheet.Rows(1).Cells(processIndex).Value = processName
processValues = processColumn.Offset(1, 0).Resize(processColumn.Rows.Count - 1, 1)
systemIndex = 1
For Each systemColumn In systemData.Columns
systemIndex = systemIndex + 1
systemValues = systemColumn.Offset(1, 0).Resize(systemColumn.Rows.Count - 1, 1)
If mergedSheet.Columns(1).Cells(systemIndex).Value = "" Then
systemName = systemColumn.Cells(1).Value
mergedSheet.Columns(1).Cells(systemIndex).Value = systemName
End If
mergedSheet.Cells(systemIndex, processIndex).Value = _
IntersectOfValues(processUsers, processValues, systemUsers, systemValues)
Next systemColumn
Next processColumn
End Sub
Private Function IntersectOfValues( _
ByVal processUsers As Variant, _
ByVal processValues As Variant, _
ByVal systemUsers As Variant, _
ByVal systemValues As Variant) As String
Dim i As Integer
Dim j As Integer
' Go through all process and system values.
' Compare names which correspond to values.
' Append the name to result if it was found in both process and system values.
For i = LBound(processValues) To UBound(processValues)
If Trim(processValues(i, 1)) = "" Then _
GoTo nextI
For j = LBound(systemValues) To UBound(systemValues)
If Trim(systemValues(j, 1)) = "" Then _
GoTo nextJ
If systemUsers(j, 1) = processUsers(i, 1) Then
IntersectOfValues = IntersectOfValues & processUsers(i, 1) & ","
Exit For
End If
nextJ:
Next j
nextI:
Next i
If Len(IntersectOfValues) = 0 Then _
Exit Function
If Right(IntersectOfValues, 1) = "," Then _
IntersectOfValues = Left(IntersectOfValues, Len(IntersectOfValues) - 1)
End Function
I need help in creating a macro in Excel wherein it grabs a certain cell and copies the entire row x number of times depending on the cell's contents.
To make it clear, let's say I have 2 rows:
| Order # | Item | Qty |
| 30001 | bag | 3 |
| 30002 | pen | 1 |
What I want the macro to do is grab the number under the Qty column and copy the entire row and insert a new line with the exact same contents under it. The number of times it does this depends on the number in the Qty cell. Also, it appends a three digit number in the Order # cell to make it a unique reference point. What the end-result should be:
| Order # | Item | Qty |
| 30001-001 | bag | 1 |
| 30001-002 | bag | 1 |
| 30001-003 | bag | 1 |
| 30002-001 | pen | 1 |
It's hard to explain it here but I hope you get the point. Thanks in advance, gurus!
The following code supports blank lines in the middle of the data.
If Qty = 0, it won't write the Item in the output table.
Please insert at least 1 row of data, because it won't work if there is no data :)
Option Explicit
Sub caller()
' Header at Row 1:
' "A1" = Order
' "B1" = Item
' "C1" = Qty
'
' Input Data starts at Row 2, in "Sheet1"
'
' Output Data starts at Row 2, in "Sheet2"
'
' Sheets must be manually created prior to running this program
Call makeTheThing(2, "Sheet1", "Sheet2")
End Sub
Sub makeTheThing(lStartRow As Long, sSheetSource As String, sSheetDestination As String)
Dim c As Range
Dim rOrder As Range
Dim sOrder() As String
Dim sItem() As String
Dim vQty As Variant
Dim sResult() As String
Dim i As Long
' Reads
With ThisWorkbook.Sheets(sSheetSource)
Set rOrder = .Range(.Cells(lStartRow, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)) ' It will work if there are blank lines in the middle!
i = rOrder.Rows.Count
ReDim sOrder(1 To i)
ReDim sItem(1 To i)
ReDim vQty(1 To i)
i = 1
For Each c In rOrder
sOrder(i) = Trim(c.Text)
sItem(i) = Trim(c.Offset(0, 1).Text)
vQty(i) = c.Offset(0, 2).Value
i = i + 1
Next c
End With
' Processes
sResult = processData(sOrder, sItem, vQty)
' Writes
ThisWorkbook.Sheets(sSheetDestination).Range("A" & lStartRow).Resize(UBound(sResult, 1), UBound(sResult, 2)).Value = sResult
End Sub
Function processData(sOrder() As String, sItem() As String, vQty As Variant) As String()
Dim i As Long
Dim j As Long
Dim k As Long
Dim sResult() As String
j = WorksheetFunction.Sum(vQty) ' That's why vQty had to be Variant!
ReDim sResult(0 To j, 1 To 3)
k = 0
For i = 1 To UBound(sOrder)
For j = 1 To vQty(i)
sResult(k, 1) = sOrder(i) & "-" & Format(j, "000")
sResult(k, 2) = sItem(i)
sResult(k, 3) = "1"
k = k + 1
Next j
Next i
processData = sResult
End Function
I hope it helps you. I had fun making it!
One way: Walk down the qty column inserting as needed then jumping to the next original row;
Sub unwind()
Dim rowCount As Long, cell As Range, order As String, i As Long, r As Long
Set cell = Range("C1")
rowCount = Range("C" & rows.Count).End(xlUp).Row
For i = 1 To rowCount
order = cell.Offset(0, -2).Value
For r = 0 To cell.Value - 1
If (r > 0) Then cell.Offset(r).EntireRow.Insert
cell.Offset(r, 0).Value = 1
cell.Offset(r, -1).Value = cell.Offset(0, -1).Value
cell.Offset(r, -2).Value = order & "-" & Format$(r + 1, "000")
Next
Set cell = cell.Offset(r, 0)
Next
End Sub