Related
I have a table of hours against weeks (start of the week is a Sunday). The weekly data goes up to 12-16 months dependent on user input. I want to create a VBA macro which will iterate through this table of weekly hours data and convert the columns into monthly data.
Example:
All October 2021 related columns will collapse into 1 column called Oct-21. This will also combine the hours. 2nd row in the image below would equal 4+3+4+0= therefore value would be 11 in the new combined column's 2nd row.
My current thinking was calculating the Sundays between the start date and the last date which is below:
Dim d As Date, format As String, w As Long, FirstSunday As String
format = format(lastMonth, "Medium Date")
d = DateSerial(Year(format), Month(format), 1)
w = Weekday(d, vbSunday)
FirstSunday = d + IIf(w <> 1, 8 - w, 0)
Any ideas on how to do this?
Not sure how you want to group the weeks into months as some months will have 5 weeks. This code inserts a column when the month changes and then fills it with a sum formula for the relevant week columns. It assumes the dates are on row 1 , the task numbers in column 1 and the first week is in column 2.
Option Explicit
Sub ByMonth()
Dim wb As Workbook, ws As Worksheet
Dim LastCol As Long, LastRow As Long, c As Long, n As Long
Dim dt As Date
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
' scan cols from right to left insert new columns
Application.ScreenUpdating = False
For c = LastCol + 1 To 3 Step -1
' add columns on month change
If Month(ws.Cells(1, c)) <> Month(ws.Cells(1, c - 1)) Then
ws.Columns(c).Insert
With ws.Columns(c)
.HorizontalAlignment = xlCenter
'.Interior.Color = RGB(255, 255, 200)
.Font.Bold = True
.Cells(1).NumberFormat = "#"
End With
End If
Next
' scan left to right filling new cols with sum() formula
' hide weekly columns
LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
n = 0
For c = 2 To LastCol + 1
If ws.Cells(1, c) = "" Then
dt = ws.Cells(1, c - 1)
ws.Cells(1, c) = MonthName(Month(dt), True) & " " & Year(dt)
ws.Cells(2, c).Resize(LastRow - 1).FormulaR1C1 = "=SUM(RC[-" & n & "]:RC[-1])"
n = 0
Else
ws.Columns(c).EntireColumn.Hidden = True
n = n + 1
End If
Next
' copy visible month columns to sheet2
ws.Cells.SpecialCells(xlCellTypeVisible).Copy
With wb.Sheets("Sheet2")
.Activate
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").Select
End With
' end
ws.Columns.Hidden = False
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Done"
End Sub
Please, try the next code. It assumes that in column A:A, starting from the 6th row, there are (not sorted) tasks. If they are sorted, the code will run without problem, too. It uses arrays and a dictionary and mostly working in memory, should be very fast for big ranges:
Sub SumWeeksMonths()
Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, arrWk, arrMonths, arrTasks
Dim i As Long, k As Long, j As Long, El, arr, arrFin, dict As New Scripting.Dictionary
Set sh = ActiveSheet 'use there the sheet to be processed
Set sh1 = sh.Next 'use here the sheet where the processed result to be returned
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row (in column A:A)
arrWk = sh.Range(sh.Range("B5"), sh.cells(5, sh.Columns.count).End(xlToLeft)).Value 'place the Week headers in a 2D array
ReDim arrMonths(UBound(arrWk, 2) - 1)'redim the 1D array to keep the unique munths, at a maximum size
For i = 1 To UBound(arrWk, 2) - 1 'create the array of (only) months:
If month(DateValue(arrWk(1, i))) <> month(DateValue(arrWk(1, i + 1))) Then
k = k + 1: arrMonths(k) = Format(DateValue(arrWk(1, i + 1)), "mmm-yyyy")
Else
arrMonths(k) = Format(DateValue(arrWk(1, i)), "mmm-yyyy")
End If
Next i
ReDim Preserve arrMonths(k) 'preserve only the existing Date elements
For Each El In sh.Range("A4:A" & lastR).Value
dict(El) = 1 'extract the unique tasks (only to count them for ReDim the necessary array)
Next El
'place all the range to be processed in an array (for faster iteration):
arr = sh.Range("A5", sh.cells(lastR, sh.cells(5, sh.Columns.count).End(xlToLeft).Column)).Value
ReDim arrFin(1 To UBound(dict.Keys) + 1, 1 To UBound(arrMonths) + 2) 'reDim the final array to keep processed data
ReDim arrTasks(UBound(arrMonths)) 'redim the array to temporarily keep the array of each task summ
dict.RemoveAll: k = 0 'clear the dictionary and reitinialize the K variable
For i = 2 To UBound(arr) 'iterate between the main array elements:
If Not dict.Exists(arr(i, 1)) Then 'if the Task key does not exist:
For Each El In arrMonths 'iterate between each month in arrMonths:
For j = 2 To UBound(arr, 2) 'iterate between all arr columns for the i row:
If month(DateValue(arr(1, j))) = month(El) Then 'if column months is a specific arrMonths column:
arrTasks(k) = arrTasks(k) + arr(i, j) 'sumarize everything in the arrTask each element
End If
Next j
k = k + 1 'increment k, for the next month
Next El
dict.Add arr(i, 1), arrTasks 'create the dictionary key with the tasks array as item
ReDim arrTasks(UBound(arrMonths)): k = 0 'reinitialize arrTasks and k variable
Else 'if dictionary (task) key exists:
For Each El In arrMonths
For j = 2 To UBound(arr, 2)
If month(DateValue(arr(1, j))) = month(El) Then
arrTasks(k) = dict(arr(i, 1))(k) + arr(i, j) 'add the sum to the allready existing elements
End If
Next j
k = k + 1
Next El
dict(arr(i, 1)) = arrTasks 'make the item the updaded array
ReDim arrTasks(UBound(arrMonths)): k = 0 'reinitialize arrTasks and k variable
End If
Next i
'place the processed values in final array (arrFin):
For i = 0 To UBound(arrMonths) 'firstly the headers:
arrFin(1, i + 2) = arrMonths(i)
Next i
'Extract the tasks value for each month and place in the final array appropriate columns:
For i = 0 To dict.count - 1 'iterate between the dictionary elements:
arrFin(i + 2, 1) = dict.Keys(i) 'place the task in the array first column, starting from the second row
For j = 0 To UBound(dict.items(i)) 'iterate between the dictionary item array elements
arrFin(i + 2, j + 2) = dict.items(i)(j) 'place the appropriate array elements in the final array (arrFin)
Next j
Next i
'drop the final array at once and make some formatting:
With sh1.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
.Value = arrFin
With .rows(1)
.Font.Bold = True
.Interior.ColorIndex = 20
.BorderAround 1
End With
.EntireColumn.AutoFit
.BorderAround 1
End With
sh1.Activate 'to see the processing result...
MsgBox "Ready..."
End Sub
Please, test it and send some feedback.
Looking for a little more help please. I was here a month ago a RiskyPenguin gave me a great bit of code. I would like to add to this.
This is the part that works:
So if the "invoice" spreadsheet (sheet 5), if cell G4 (for example is I111) matches any of the data in the first column of the "income" spreadsheet (sheet 1) (starting at row 6) then the corresponding data in columns 2 3, 8 & 9 will copy over to the "invoice" spreadsheet in columns 2, 3, 4 & 5 (starting at row 13).
Sub FindAndCopyData2()
Dim shData As Worksheet, shReport As Worksheet
Set shData = Sheet1
Set shReport = Sheet6
Dim strInvoceNumber As String
strInvoceNumber = shReport.Cells(4, "E").Value
Dim intLastRow As Integer
intLastRow = shData.Cells(Rows.Count, 1).End(xlUp).Row
Dim intReportRow As Integer
intReportRow = 13
shReport.Range("B13:E20").ClearContents
Dim i As Integer
For i = 1 To intLastRow
If shData.Cells(i, 1).Value2 = strInvoceNumber Then
shReport.Cells(intReportRow, 2).Value2 = shData.Cells(i, 3).Value2
shReport.Cells(intReportRow, 3).Value2 = shData.Cells(i, 4).Value2
shReport.Cells(intReportRow, 4).Value2 = shData.Cells(i, 8).Value2
shReport.Cells(intReportRow, 5).Value2 = shData.Cells(i, 9).Value2
intReportRow = intReportRow + 1
End If
Next i
End Sub
I would then like to (hopefully using the same search)
Take the "invoice" spreadsheet (sheet 5), if cell G4 (for example is I111) matches any of the data in the second column of the "expenses" spreadsheet (sheet 2) (starting at row 11) then the corresponding data in columns 3, 5, & 7 will copy over to the "invoice" spreadsheet in columns 2, 4 & 6 (starting at row 13).
Is this possible or does it have to be a separate piece of programming?
Many Thanks for any advise.
Assuming this could be useful for others I made a function out of it and refactored the initial code to handle the copy in memory. I setup your first lookup so you just need to edit the variables to get your second lookup:
Option Explicit
''''''''''''''''''''''''''''''''''''''
''Main Sub
''''''''''''''''''''''''''''''''''''''''''''''''''
Sub main()
'Set some vars
Dim sourceArr, targetArr, sourceCls, targetCls, sourceStartRw As Long, targetStartRw As Long, dict As Object, j As Long, sourceLookupCl As Long, Matchkey As Long
''''''''''''''''''''''''''''''''''''''
''Lookup 1
''''''''''''''''''''''''''''''''''''''''''''''''''
Matchkey = Sheet5.Range("G4").Value2 'lookupKey
sourceCls = Split("2,3,8,9 ", ",") 'Columns to copy from
targetCls = Split("2,3,4,5", ",") 'Columns to copy to
sourceStartRw = 6
targetStartRw = 13
sourceLookupCl = 1 'matching column
'get data in memory = array
sourceArr = Sheet1.Range("A1").CurrentRegion.Value2
'call our function
targetArr = reorder(sourceArr, sourceCls, targetCls, sourceStartRw, sourceLookupCl, Matchkey)
'dump to sheet
With Sheet5
.Range(.Cells(targetStartRw, 1), .Cells(UBound(targetArr) + targetStartRw - 1, UBound(targetArr, 2))).Value2 = targetArr
End With
''''''''''''''''''''''''''''''''''''''
''Lookup 2 => change source and target cols to your need
''''''''''''''''''''''''''''''''''''''''''''''''''
Matchkey = Sheet5.Range("G4").Value2
sourceCls = Split("2,3,8,9 ", ",")
targetCls = Split("2,3,4,5", ",")
sourceStartRw = 6
targetStartRw = 13 'must be the same as previous lookup if you want to keep the targetArr from previous lookups
sourceLookupCl = 1
'get data in memory = array
sourceArr = Sheet1.Range("A1").CurrentRegion.Value2
'call our function keeping the data from the first lookup
targetArr = reorder(sourceArr, sourceCls, targetCls, sourceStartRw, sourceLookupCl, Matchkey, targetArr)
'dump to sheet
With Sheet5
.Range(.Cells(targetStartRw, 1), .Cells(UBound(targetArr) + targetStartRw - 1, UBound(targetArr, 2))).Value2 = targetArr
End With
End Sub
''''''''''''''''''''''''''''''''''''''
''Supporting function
''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function reorder(sourceArr, sourceCls, targetCls, sourceStartRw As Long, sourceLookupCl As Long, Matchkey As Long, Optional targetArr) As Variant
Dim dict As Object, j As Long
'if the target array overlaps the previous lookups pass it to the function
If IsMissing(targetArr) Then
ReDim targetArr(1 To UBound(sourceArr), 1 To UBound(sourceArr, 2))
End If
'build a dict to compare quickly
Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
For j = 1 To UBound(sourceArr) 'traverse source
dict(sourceArr(j, sourceLookupCl)) = Empty
Next j
'check if key exists in dict and copy data
Dim i As Long, ii As Long ': ii = 1
If dict.Exists(Matchkey) Then
For j = sourceStartRw To UBound(sourceArr)
For i = 1 To UBound(sourceArr, 2)
If i = sourceCls(ii) Then
targetArr(j - sourceStartRw + 1, targetCls(ii)) = sourceArr(j, i)
ii = IIf(ii < UBound(sourceCls), ii + 1, ii)
End If
Next i
ii = 0
Next j
End If
reorder = targetArr
End Function
This is the kind of transformation is what I am trying to perform.
For illustration I made this as table. Basically the first three columns should repeat for however many colors are available.
I searched for similar questions but could not find when I want multiple columns to repeat.
I found this code online
Sub createData()
Dim dSht As Worksheet
Dim sSht As Worksheet
Dim colCount As Long
Dim endRow As Long
Dim endRow2 As Long
Set dSht = Sheets("Sheet1") 'Where the data sits
Set sSht = Sheets("Sheet2") 'Where the transposed data goes
sSht.Range("A2:C60000").ClearContents
colCount = dSht.Range("A1").End(xlToRight).Column
'// loops through all the columns extracting data where "Thank" isn't blank
For i = 2 To colCount Step 2
endRow = dSht.Cells(1, i).End(xlDown).Row
For j = 2 To endRow
If dSht.Cells(j, i) <> "" Then
endRow2 = sSht.Range("A50000").End(xlUp).Row + 1
sSht.Range("A" & endRow2) = dSht.Range("A" & j)
sSht.Range("B" & endRow2) = dSht.Cells(j, i)
sSht.Range("C" & endRow2) = dSht.Cells(j, i).Offset(0, 1)
End If
Next j
Next i
End Sub
I tried changing step 2 to 1 and j to start from 4.
Another example with two varied sets:
Here's a generic "unpivot" approach (all "fixed" columns must appear on the left of the columns to be unpivoted)
Test sub:
Sub Tester()
Dim p
'get the unpivoted data as a 2-D array
p = UnPivotData(Sheets("Sheet1").Range("A1").CurrentRegion, _
3, False, False)
With Sheets("Sheet1").Range("H1")
.CurrentRegion.ClearContents
.Resize(UBound(p, 1), UBound(p, 2)).Value = p 'populate array to sheet
End With
'EDIT: alternative (slower) method to populate the sheet
' from the pivoted dataset. Might need to use this
' if you have a large amount of data
'Dim r As Long, c As Long
'For r = 1 To Ubound(p, 1)
'For c = 1 To Ubound(p, 2)
' Sheets("Sheet2").Cells(r, c).Value = p(r, c)
'Next c
'Next r
End Sub
UnPivot function - should not need any modifications:
Function UnPivotData(rngSrc As Range, fixedCols As Long, _
Optional AddCategoryColumn As Boolean = True, _
Optional IncludeBlanks As Boolean = True)
Dim nR As Long, nC As Long, data, dOut()
Dim r As Long, c As Long, rOut As Long, cOut As Long, cat As Long
Dim outRows As Long, outCols As Long
data = rngSrc.Value 'get the whole table as a 2-D array
nR = UBound(data, 1) 'how many rows
nC = UBound(data, 2) 'how many cols
'calculate the size of the final unpivoted table
outRows = nR * (nC - fixedCols)
outCols = fixedCols + IIf(AddCategoryColumn, 2, 1)
'resize the output array
ReDim dOut(1 To outRows, 1 To outCols)
'populate the header row
For c = 1 To fixedCols
dOut(1, c) = data(1, c)
Next c
If AddCategoryColumn Then
dOut(1, fixedCols + 1) = "Category"
dOut(1, fixedCols + 2) = "Value"
Else
dOut(1, fixedCols + 1) = "Value"
End If
'populate the data
rOut = 1
For r = 2 To nR
For cat = fixedCols + 1 To nC
If IncludeBlanks Or Len(data(r, cat)) > 0 Then
rOut = rOut + 1
'Fixed columns...
For c = 1 To fixedCols
dOut(rOut, c) = data(r, c)
Next c
'populate unpivoted values
If AddCategoryColumn Then
dOut(rOut, fixedCols + 1) = data(1, cat)
dOut(rOut, fixedCols + 2) = data(r, cat)
Else
dOut(rOut, fixedCols + 1) = data(r, cat)
End If
End If
Next cat
Next r
UnPivotData = dOut
End Function
Here is one way (fastest?) using arrays. This approach is better that the linked question as it doesn't read and write to/from range objects in a loop. I have commented the code so you shouldn't have a problem understanding it.
Option Explicit
Sub Sample()
Dim wsThis As Worksheet, wsThat As Worksheet
Dim ThisAr As Variant, ThatAr As Variant
Dim Lrow As Long, Col As Long
Dim i As Long, k As Long
Set wsThis = Sheet1: Set wsThat = Sheet2
With wsThis
'~~> Find Last Row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Find total value in D,E,F so that we can define output array
Col = Application.WorksheetFunction.CountA(.Range("D2:F" & Lrow))
'~~> Store the values from the range in an array
ThisAr = .Range("A2:F" & Lrow).Value
'~~> Define your new array
ReDim ThatAr(1 To Col, 1 To 4)
'~~> Loop through the array and store values in new array
For i = LBound(ThisAr) To UBound(ThisAr)
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
'~~> Check for Color 1
If ThisAr(i, 4) <> "" Then ThatAr(k, 4) = ThisAr(i, 4)
'~~> Check for Color 2
If ThisAr(i, 5) <> "" Then
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 4) = ThisAr(i, 5)
End If
'~~> Check for Color 3
If ThisAr(i, 6) <> "" Then
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 4) = ThisAr(i, 6)
End If
Next i
End With
'~~> Create headers in Sheet2
Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value
'~~> Output the array
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
End Sub
SHEET1
SHEET2
The addition of the LET function allows for this non-VBA solution.
=LET(data,B3:F6,
dataRows,ROWS(data),
dataCols,COLUMNS(data),
rowHeaders,OFFSET(data,0,-1,dataRows,1),
colHeaders,OFFSET(data,-1,0,1,dataCols),
dataIndex,SEQUENCE(dataRows*dataCols),
rowIndex,MOD(dataIndex-1,dataRows)+1,
colIndex,INT((dataIndex-1)/dataRows)+1,
FILTER(CHOOSE({1,2,3}, INDEX(rowHeaders,rowIndex), INDEX(colHeaders,colIndex), INDEX(data,rowIndex,colIndex)), index(data,rowIndex,colIndex)<>""))
Below is a custom function I wrote for such things (demo video I posted on YouTube). A few differences from other answers:
The custom function allows for more than one axis in columns. As shown below, the column axis has Currency and Time.
Row axis does not need to be directly next to the data range.
One can specify the entire row as the column axis or the entire column to specify the row axis. See formula used as example below.
So with this data set:
And entering this as the formula:
=unPivotData(D4:G7,2:3,B:C)
an output of this:
Function unPivotData(theDataRange As Range, theColumnRange As Range, theRowRange As Range, _
Optional skipZerosAsTrue As Boolean, Optional includeBlanksAsTrue As Boolean)
'Set effecient range
Dim cleanedDataRange As Range
Set cleanedDataRange = Intersect(theDataRange, theDataRange.Worksheet.UsedRange)
'tests Data ranges
With cleanedDataRange
'Use intersect address to account for users selecting full row or column
If .EntireColumn.Address <> Intersect(.EntireColumn, theColumnRange).EntireColumn.Address Then
unPivotData = "datarange missing Column Ranges"
ElseIf .EntireRow.Address <> Intersect(.EntireRow, theRowRange).EntireRow.Address Then
unPivotData = "datarange missing row Ranges"
ElseIf Not Intersect(cleanedDataRange, theColumnRange) Is Nothing Then
unPivotData = "datarange may not intersect column range. " & Intersect(cleanedDataRange, theColumnRange).Address
ElseIf Not Intersect(cleanedDataRange, theRowRange) Is Nothing Then
unPivotData = "datarange may not intersect row range. " & Intersect(cleanedDataRange, theRowRange).Address
End If
'exits if errors were found
If Len(unPivotData) > 0 Then Exit Function
Dim dimCount As Long
dimCount = theColumnRange.Rows.Count + theRowRange.Columns.Count
Dim aCell As Range, i As Long, g As Long
ReDim newdata(dimCount, i)
End With
'loops through data ranges
For Each aCell In cleanedDataRange.Cells
With aCell
If .Value2 = "" And Not (includeBlanksAsTrue) Then
'skip
ElseIf .Value2 = 0 And skipZerosAsTrue Then
'skip
Else
ReDim Preserve newdata(dimCount, i)
g = 0
'gets DimensionMembers members
For Each gcell In Union(Intersect(.EntireColumn, theColumnRange), _
Intersect(.EntireRow, theRowRange)).Cells
newdata(g, i) = IIf(gcell.Value2 = "", "", gcell.Value)
g = g + 1
Next gcell
newdata(g, i) = IIf(.Value2 = "", "", .Value)
i = i + 1
End If
End With
Next aCell
unPivotData = WorksheetFunction.Transpose(newdata)
End Function
I would like to get the unique values from column A and all the corresponding values from column B in excel. So transform this:
Into that:
Is it possible in Excel?
With data like this in Sheet1:
running this macro:
Sub dural()
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Long, j As Long, st As String
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
s1.Range("A:A").Copy s2.Range("A1")
s2.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
For Each r In s2.Range("A:A")
v = r.Value
If v = "" Then Exit Sub
For Each rr In s1.Range("A:A")
vv = rr.Value
If vv = "" Then Exit For
If v = vv Then
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = rr.Offset(0, 1).Value
Else
r.Offset(0, 1).Value = r.Offset(0, 1).Value & " ," & rr.Offset(0, 1).Value
End If
End If
Next rr
Next r
End Sub
Will produce this in Sheet2:
NOTE:
The data in Sheet1 is not required to be sorted.
Try this one:
Sub Test()
Dim objIds, arrData, i, strId
Set objIds = CreateObject("Scripting.Dictionary")
arrData = Range("A1:B8").Value ' put here your source range
For i = LBound(arrData, 1) To UBound(arrData, 1)
If IsEmpty(objIds(arrData(i, 1))) Then
objIds(arrData(i, 1)) = arrData(i, 2)
Else
objIds(arrData(i, 1)) = objIds(arrData(i, 1)) & ", " & arrData(i, 2)
End If
Next
i = 1 ' first row for output
For Each strId In objIds
Cells(i, 3) = strId ' first column for output
Cells(i, 4) = objIds(strId) ' second column for output
i = i + 1
Next
End Sub
This is all you need and nothing must be sorted:
Sub Sam()
Dim c&, i&, d$, s$, v, w
v = [a1].CurrentRegion.Resize(, 2)
ReDim w(1 To UBound(v), 1 To 2)
For i = 1 To UBound(v)
d = ", "
If s <> v(i, 1) Then d = "": c = c + 1: s = v(i, 1): w(c, 1) = s
w(c, 2) = w(c, 2) & d & v(i, 2)
Next
[d1:e1].Resize(UBound(w)) = w
End Sub
This code is extremely fast. If you were to process a large list, the efficiency here would be appreciated.
You can manage where the source data is and where the output should be written by adjusting the addresses in the square brackets at the top and bottom of the procedure.
Looking at how to solve this using Excel formulae only (I know there is a VBA tag in the OP), but here is another option.
Adding 2 additional columns with formulae we get this result:
By filtering on the finalList column where the value = 1 we get the desired result:
The formula that are required are as follows:
Cell C1 : =B2
Cell C2 (And copied down to all cells in Column C) : =IF(A3=A2,C2&","&B3,B3)
Cell D1 (And copied down to all cells in Column D) : =IF(A2=A3,0,1)
NOTE: This will only work when Column A is sorted.
I have data that I need to split into individual points. My macro charts the data, as a scatter plot, with: Column A as the title of the chart, Column B as the X axis, and Columns C and D as the Y axis. What I need is for when the Product ID has more than 1 number listed to split the numbers out into their own rows and keep the columns B, C, and D the same for each row created form the original. So for row 167, I would want 3 rows (001,002,003) each with packaging, 200, and 100, in B, C, and D respectively. I am not sure where to begin. I tried to build a macro but, I immediately got tripped up when I tried to record a "Find" Formula to run on the data. Any help would be greatly appreciated.
Column A: 001, 002, 003 // Column B:packaging // Column C:200 // Column D:100
Sorry I couldn't post a screenshot of my data, the forum won't let me. If you have any questions please let me know, I will be sure to check in frequently.
Thanks in advance.
I worte this VERY quickly and without much care for efficiency, but this should do the trick:
Sub SplitUpVals()
Dim i As Long
Dim ValsToCopy As Range
Dim MaxRows As Long
Dim ValToSplit() As String
Dim CurrentVal As Variant
MaxRows = Range("A1").End(xlDown).Row
For i = 1 To 10000000
ValToSplit = Split(Cells(i, 1).Value, ",")
Set ValsToCopy = Range("B" & i & ":D" & i)
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(i, 1).Value = CurrentVal
Range("B" & i & ":D" & i).Value = ValsToCopy.Value
Cells(i + 1, 1).EntireRow.Insert
i = i + 1
MaxRows = MaxRows + 1
Next
Cells(i, 1).EntireRow.Delete
If i > MaxRows Then Exit For
Next i
End Sub
As a note, make sure there's no data in cells beneath your data as it might get deleted.
You will need to parse the data in column A. I would do this by splitting the string in to an array, and then iterate over the array items to add/insert additional rows where necessary.
Without seeing your worksheet, I would probably start with something like this, which will split your cell value from column A in to an array, and then you can iterate over the items in the array to manipulate the worksheet as needed.
Sub TestSplit()
Dim myString as String
Dim myArray() as String
Dim cell as Range
Dim i as Long
For each cell in Range("A2",Range("A2").End(xlDown))
myString = cell.Value
myArray = Split(myString, ",") '<-- converts the comma-delimited string in to an array
For i = lBound(myArray) to uBound(myArray)
If i >= 1 Then
'Add code to manipulate your worksheet, here
End If
Next
Next
End Sub
This is a better solution (now that I had more time :) ) - Hope this does the trick!
Sub SplitUpVals()
Dim AllVals As Variant
Dim ArrayIndex As Integer
Dim RowLooper As Integer
AllVals = Range("A1").CurrentRegion
Range("A1").CurrentRegion.Clear
RowLooper = 1
For ArrayIndex = 1 To UBound(AllVals, 1)
ValToSplit = Split(AllVals(ArrayIndex, 1), ",")
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(RowLooper, 1).Value = CurrentVal
Cells(RowLooper, 2).Value = AllVals(ArrayIndex, 2)
Cells(RowLooper, 3).Value = AllVals(ArrayIndex, 3)
Cells(RowLooper, 4).Value = AllVals(ArrayIndex, 4)
RowLooper = RowLooper + 1
Next
Next ArrayIndex
End Sub
Sub DivideData()
'This splits any codes combined into the same line, into their own separate lines with their own separate data
Dim a, b, txt As String, e, s, x As Long, n As Long, i As Long, ii As Long
With Range("a1").CurrentRegion
a = .Value
txt = Join$(Application.Transpose(.Columns(1).Value))
x = Len(txt) - Len(Replace(txt, ",", "")) + .Rows.Count
ReDim b(1 To x * 2, 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
For Each e In Split(a(i, 1), ",")
If e <> "" Then
For Each s In Split(e, "-")
n = n + 1
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
b(n, 1) = s
Next
End If
Next
Next
With .Resize(n)
.Columns(1).NumberFormat = "#"
.Value = b
End With
End With
End Sub