Given three columns ID, S/E, and Date (there are two rows for each ID) we want to Split the Date column into two columns Start and End based on Matching ID and S/E.
I have tried a couple of options.
Approach 1
So, far I was doing it by using a table:
Column Start:
=IF([#[S/E]]="Start",[#[Date]],"")
Column End:
=IF([#[S/E]]="End",[#[Date]],"")
I would like for the Date under Start and End column to show on every row.
Like:
Then Add a column that calculates the difference between the dates:
Function TestDates(pDate1 As Date, pDate2 As Date) As Long
TestDates = DateDiff("d", pDate1, pDate2)
End Function
Column DateFif
=ABS(TestDates([#[End]],[#[Start]]))
Approach 2
I have also tried the following Macro
Sub ConcatenateCellsIfSameValues()
Dim xCol As New Collection
Dim xSrc As Variant
Dim xRes() As Variant
Dim I As Long
Dim J As Long
Dim xRg As Range
xSrc = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
Set xRg = Range("D1")
On Error Resume Next
For I = 2 To UBound(xSrc)
xCol.Add xSrc(I, 1), TypeName(xSrc(I, 1)) & CStr(xSrc(I, 1))
Next I
On Error GoTo 0
ReDim xRes(1 To xCol.Count + 1, 1 To 2)
xRes(1, 1) = "No"
xRes(1, 2) = "Combined Date"
For I = 1 To xCol.Count
xRes(I + 1, 1) = xCol(I)
For J = 2 To UBound(xSrc)
If xSrc(J, 1) = xRes(I + 1, 1) Then
xRes(I + 1, 2) = xRes(I + 1, 2) & ", " & xSrc(J, 2)
End If
Next J
xRes(I + 1, 2) = Mid(xRes(I + 1, 2), 2)
Next I
Set xRg = xRg.Resize(UBound(xRes, 1), UBound(xRes, 2))
xRg.NumberFormat = "#"
xRg = xRes
xRg.EntireColumn.AutoFit
End Sub
Which could be a good start but not sure how to tune for this goal
THANKS and ANY help is appreciated it!
(Even better if the macro is for a table)
Use SUMIFS()
Start:
=SUMIFS([Date],[S/E],"Start",[Trade Id],[#Trade Id])
End:
=SUMIFS([Date],[S/E],"End",[Trade Id],[#Trade Id])
For the date diff, no need for vba:
=INT(ABS([#End]-[#Start]))
Related
I am trying to remove rows from a spreadsheet in VBA if the sum total of value exceeds a specific amount.
For example, if I have the following data, names in A1 down and values in A2 down:
I would like to remove all rows where the total sum of the value in row A does not reach 10 or above in row B, this would leave the following results:
Thomas = 18 and John = 15 so all rows with Thomas and John are kept.
All other rows would be deleted.
Please note that I will always know that the data is in row A and B but I do not know how many rows there will be and need to execute until the first blank cell.
It worked. You can see this here:
Sub run()
Dim rowIndex, countSameRow, sumSameRow As Integer
sumSameRow = Cells(1, 2)
rowIndex = 2
countSameRow = 1
While IsEmpty(Cells(rowIndex, 1)) = False
If (Cells(rowIndex, 1) = Cells(rowIndex - 1, 1)) Then
sumSameRow = sumSameRow + Cells(rowIndex, 2)
countSameRow = countSameRow + 1
Else
If (sumSameRow < 10) Then
Rows(rowIndex - 1 & ":" & rowIndex - countSameRow).Delete
rowIndex = rowIndex - countSameRow
End If
countSameRow = 1
sumSameRow = Cells(rowIndex, 2)
End If
If IsEmpty(Cells(rowIndex + 1, 1)) Then
If (sumSameRow < 10) Then
Rows(rowIndex & ":" & rowIndex - countSameRow + 1).Delete
End If
End If
rowIndex = rowIndex + 1
Wend
End Sub
Totally agree you should write your own code first, but I couldn't help but write some starting code for you. See if the below fits your purpose:
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant, rng As Range
Dim dict1 As Object: Set dict1 = CreateObject("Scripting.Dictionary")
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
With Sheet1 'Change according to your sheets CodeName
'Get all of your data form A:B in memory (array)
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A1:B" & lr)
'Step through the array and fill up our two dictionaries
For x = LBound(arr) To UBound(arr)
If dict1(arr(x, 1)) <> "" Then
dict1(arr(x, 1)) = Join(Array(dict1(arr(x, 1)), x & ":" & x), ",")
Else
dict1(arr(x, 1)) = x & ":" & x
End If
dict2(arr(x, 1)) = dict2(arr(x, 1)) + arr(x, 2)
Next x
'Step through our second dictionary and check if value < 10
For Each Key In dict2.keys
If dict2(Key) < 10 Then
If Not rng Is Nothing Then
Set rng = Union(rng, .Range(dict1(Key)))
Else
Set rng = .Range(dict1(Key))
End If
End If
Next Key
'If any where below 10, this Range object has been filled, so delete it.
If Not rng Is Nothing Then
rng.Delete
End If
End With
End Sub
Here is another method that uses Autofilter and SUMIF to delete the lines.
This assumes there is a header row, if not then add a row first.
It adds a sumif in column C and filters all that is less than 10, then deletes them.
Then removes column C again.
Sub filter()
Range("C1").Value = "Sum"
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("C2:C" & Lastrow).Formula = "=sumif(A:A,A2,B:B)"
Range("A2").AutoFilter ' add a filter to table
ActiveSheet.Range("$A$1:$C$" & Lastrow).AutoFilter Field:=3, Criteria1:="<10", Operator:=xlAnd ' filter all below 10
ActiveSheet.Range("A2:C" & Lastrow).SpecialCells(xlCellTypeVisible).EntireRow.Delete ' delete them
Range("A1").AutoFilter ' remove filter again
Columns("C:C").EntireColumn.Delete ' remove column C
End Sub
Need any help on how I can achieve as in the image below.
I want to combine multiple rows of the same person into one while transposing the column value of the person into a single row. I would like to achieve doing it preferable via VBA but if not then by formula.
Sorry I don't have anything to show. I already have the codes to generate a unique list for the names but I don't know how to transpose the data in the respective columns. I don't have any idea on how to approach this problem. Seeking any guidance or even ideas.
Public Sub extractUniques(rngSource As Range, rngTarget As Range)
Application.ScreenUpdating = False
rngSource.AdvancedFilter Action:=xlFilterCopy, _
copytorange:=rngTarget, Unique:=True
Application.ScreenUpdating = True
End Sub
Try this!
Sub specialTransfer()
Dim inp As Range, outp As Range, rng As Range, c As Range, data(), u, r, x, i, j
Set inp = [A1] 'Change this to the top left cell of your input
Set outp = [F1] 'Change this to the top left cell of your output
Set rng = Range(inp.Offset(1, 1), Cells(Rows.Count, 2).End(xlUp))
data = rng.Value
Set u = CreateObject("Scripting.Dictionary")
For r = 1 To UBound(data)
u(data(r, 1)) = Empty
Next r
x = u.Keys()
'Option to clear out everything past the outputcell
'Range(outp, Cells(Rows.Count, Columns.Count)).ClearContents
outp = "Name"
For i = 0 To u.Count - 1
j = 1
outp.Offset(i + 1) = x(i)
For Each c In rng
Range(outp.Offset(, j), outp.Offset(, j + 2)) = Array("Day", "Time out", "Time in")
If WorksheetFunction.CountA(c.Offset(, -1).Resize(, 4)) = 4 Then
If c = x(i) Then
outp.Offset(i + 1, j).Value = Format(Mid(c.Offset(, -1), 4, 10), "General Number")
outp.Offset(i + 1, j + 1).Value = Format(c.Offset(, 1), "h:mm AM/PM")
outp.Offset(i + 1, j + 2).Value = Format(c.Offset(, 2), "h:mm AM/PM")
j = j + 3
End If
End If
Next c
Next i
End Sub
Hoping to be able to achieve it via VBA but don't think that I can. It's not the exact result I was hoping for but it works. Did it using array formula below.
=IFERROR(INDEX("table data",MATCH(1,("criteria1 column"="criteria1")*("criteria2 column"="criteria2")*("criteria3 column"<>""),0), "criteria3 colNum"),"")
Ctrl + Shift + Enter
multiple row into one
Good morning! I'm trying to create a VBA function and appreciate any help you can provide to get me on the right track. In short, for each value in Column A of Worksheet Exams, I need to concatenate all the unique values in Column B in Worksheet Findings in which Column A of Worksheet Exams = Column A of Worksheet Findings. I'm struggling with where to start, and can't seem to find any good guidance. In advance, thank you for your help. Much appreciated.
Started with this to get my bearings on the concat... I know the & ExamID portion is wrong, but I'm not sure what code I need there to Concatenate with the next instance of that RX721502:
Dim ExamID As Range
Dim strConcat As String
Dim i As Integer
i = 2
Do While Cells(i, 1).Value <> ""
For Each ExamID In Range("A2:A10000")
If InStr(ExamID.Value, "RX721502") > 0 Then
Cells(i, 18).Value = ActiveCell.Offset(0, 10) & ", " & ExamID
End If
Next ExamID
Cells(2, 18) = Trim(Cells(2, 18))
i = i + 1
Loop
G
try the following code, it puts the Concatenate string of Cities in Worksheet SourceExams, Column 2.
Sub use_VLookup()
Dim conOG As String
Dim SourceExams As Worksheet
Dim SourceFindings As Worksheet
Dim lastrow, lastrow2 As Long
Dim rowfound As Long
Dim Vlookup_result As Variant
Set SourceExams = ActiveWorkbook.Sheets("Source-Exams")
Set SourceFindings = ActiveWorkbook.Sheets("Source-Findings")
lastrow = SourceExams.UsedRange.Rows.count
lastrow2 = SourceFindings.UsedRange.Rows.count
For i = 2 To lastrow
j = 2
While j <= lastrow2
' search Worksheet Cities workcheet for match on Column A, and return the value in column B
Vlookup_result = Application.VLookup(SourceExams.Cells(i, 1), SourceFindings.Range(SourceFindings.Cells(j, 1), SourceFindings.Cells(lastrow2, 2)), 2, False)
If IsError(Vlookup_result) Then
' do nothing , you can add erro handling, but I don't think it's necesary
Else
conOG = conOG & ", " & Application.WorksheetFunction.VLookup(SourceExams.Cells(i, 1), SourceFindings.Range(SourceFindings.Cells(j, 1), SourceFindings.Cells(lastrow2, 2)), 2, False)
rowfound = Application.WorksheetFunction.Match(SourceExams.Cells(i, 1), SourceFindings.Range(SourceFindings.Cells(j, 1), SourceFindings.Cells(lastrow2, 1)), 0)
End If
j = j + rowfound
' if first found go to row 3
If j <= 2 Then j = 3
Wend
SourceExams.Cells(i, 2) = conOG
conOG = ""
Next i
End Sub
My code mostly works but it's taking a while to debug so I am beginning to think my architecture may be flawed XD So how can I architect this better?
I have groups of data separated by a blank row. You can tell each group apart by the ID in column C in addition to the blank row. For each ID, I have various numbers in column B that I need to capture. Sometimes those numbers only start with 5, sometimes it starts with 7. I need to capture the 5 and the 7 separately.
With projWS
With .Range("C1:C6000")
Set f = .Find(cc, LookIn:=xlValues, lookat:=xlPart)
End With
If Not f Is Nothing Then 'first occurence found
counter = 0
i = f.Row
Do
acct = .Cells(i, 2)
If (Len(projWS.Cells(i, 3)) < 1 Or Left(acct, 1) = "7") And done = False Then
acctStart = f.Row
acctRows = i - acctStart
Set acctRng = .Range(.Cells(acctStart, 2), .Cells(i - 1, 5))
Set amountRng = .Range(.Cells(acctStart, 7), .Cells(i - 1, 8))
done = True 'set flag to show range has been filled
End If
counter = counter + 1 'increment counter
i = i + 1 'move to next row
Loop Until Len(.Cells(i, 3)) < 1 'keep looping until blank row
End If
If counter - 1 > acctRows Then 'how we determine if there's a "7"
flag = True 'so we set flag to true
Set depreRng = Range(.Cells(acctStart + acctRows, 2), .Cells(i - 1, 8))
dep = depreRng.Value2 'store range into array
End If
End With
After capture, I need to drop it into another worksheet. This worksheet already has a block of 7 built in. Hence this is the loop I am using to drop the range of 7. There is no built in block for the 5.
For r = 112 To 120
For k = 1 To UBound(dep())
If .Cells(r, 1).Value2 = Trim(dep(k, 1)) Then
Debug.Print .Cells(r, 1).Value2
.Cells(r, 6) = dep(k, 6)
.Cells(r, 7) = dep(k, 7)
Exit For
Else
.Cells(r, 6) = 0
.Cells(r, 7) = 0
End If
Next k
Next r
I have debugged several errors already. The current one is that depreRng is breaking because my math is bad. Instead of debugging each error as I stumble onto it, how can I architect this better?
Ok, my approach it's different. First i use a filter for find the range of rows with the index you are looking for and then loop inside this filtered rows for find the 5xx and the 7xx range. The code:
Sub Macro1()
Dim rng_5xx_start, rng_5xx_stop, rng_7xx_start, rng_7xx_stop As Integer
rng_5xx_start = 0
rng_5xx_stop = 0
rng_7xx_start = 0
rng_7xx_stop = 0
Dim range_5xx, range_7xx As String
'filter for the index you are looking for
'specify the maximum range, the field is the "offset" from the column B (the firts of the range), so for filter for column C you need to put 2, criteria...is the critera :)
ActiveSheet.Range("$B$1:$H$6000").AutoFilter Field:=2, Criteria1:="b"
'the filter returns only the rows with the specifyed index, now a for inside this rows for find the 5xx and the 7xx sub-ranges
For Each Row In ActiveSheet.Range("b1:b6000").SpecialCells(xlCellTypeVisible)
If Cells(Row.Row, 2).Value > 4999 And Cells(Row.Row, 2).Value < 6000 Then
'or any test for understnd if i'm in the 5xx range, if you prefer use the strings use something like left(cells(row.row,2).value,1) = "5"
If rng_5xx_start = 0 Then 'found the first row with a 5xx value
rng_5xx_start = Row.Row 'set the start of the range to this row
End If
If rng_5xx_stop < Row.Row Then 'the row where i am is in the 5xx range and is grater than the current end i noticed
rng_5xx_stop = Row.Row 'refresh the end of the range...at the end this will have the last number of row of the 5xx range
End If
End If
If Cells(Row.Row, 2).Value > 6999 And Cells(Row.Row, 2).Value < 8000 Then
'same as above but for 7xx range
If rng_7xx_start = 0 Then
rng_7xx_start = Row.Row
End If
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
End If
Next
If rng_5xx_start = 0 Then
'not found 5xx rows
range_5xx = "" 'or False, or what you prefer...
Else
range_5xx = "B" & rng_5xx_start & ":H" & rng_5xx_stop
End If
If rng_7xx_start = 0 Then
'not found 7xx rows
range_7xx = "" 'or False, or what you prefer...
Else
range_7xx = "B" & rng_7xx_start & ":H" & rng_7xx_stop
End If
End Sub
That's how i would imagine a macro for your job ;)
Edit 1:
I forgot that this will leave the sheet with the filter on...use activesheet.showalldata for show all the rows and not only the filtered ones
Edit 2:
The tests
If rng_5xx_stop < Row.Row Then
rng_5xx_stop = Row.Row
End If
and
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
are not necessary, it's enough do rng_5xx_stop = Row.Row and rng_7xx_stop = Row.Row and save the two IF statements
You are grouping cells based on the first number of the cell values in column B (I am assuming that they can never be letters). If that is the case, then you can create an array of 0 to 9 and store your ranges in there. Then go through the range.areas in order to get the groupings you're looking for (as highlighted in your screenshot).
To do this, something like this is all you need. I commented code to try to explain it more:
Sub tgr()
Dim wsData As Worksheet
Dim rColB As Range
Dim BCell As Range
Dim aRanges(0 To 9) As Range
Dim SubGroup As Range
Dim lRangeNum As Long
Dim i As Long
'Change to your actual worksheet
Set wsData = ActiveWorkbook.ActiveSheet
'Change to your actual column range, this is based off the sample data
Set rColB = wsData.Range("B1", wsData.Cells(wsData.Rows.Count, "B").End(xlUp))
'Loop through the column range
For Each BCell In rColB.Cells
'Make sure the cell is populated and the starting character is numeric
If Len(BCell.Value) > 0 And IsNumeric(Left(BCell.Value, 1)) Then
'Get the starting digit
lRangeNum = Val(Left(BCell.Value, 1))
'Check if any ranges have been assigned to that array index location
'If not, start a range at that array index
'If so, combine the ranges with Union
Select Case (aRanges(lRangeNum) Is Nothing)
Case True: Set aRanges(lRangeNum) = BCell
Case Else: Set aRanges(lRangeNum) = Union(aRanges(lRangeNum), BCell)
End Select
End If
Next BCell
'You can use any method you want to access the ranges, this just loops
'through the array indices and displays the range areas of each
For i = 0 To 9
If Not aRanges(i) Is Nothing Then
For Each SubGroup In aRanges(i).Areas
'Do what you want with it here
'This just selects the subgroup so you can see it found the groups properly
SubGroup.Select
MsgBox SubGroup.Address
Next SubGroup
End If
Next i
End Sub
I see you've allready rewritten your code, but I'd like to offer how I would do it and would like to know your thoughts about it. Would this be inefficient? I guess it could be because you have to read the first character in cells 4 times for every increment, but not shure if that is a big problem.
Dim start_row As Long
Dim end_row As Long
start_row = 1
end_row = 0
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i - 1, 2) = "" Then
start_row = i
ElseIf Left(Cells(i - 1, 2), 1) <> Left(Cells(i, 2), 1) Then
start_row = i
End If
If Cells(i + 1, 2) = "" Then
end_row = i
ElseIf Left(Cells(i + 1, 2), 1) <> Left(Cells(i, 2), 1) Then
end_row = i
End If
If end_row <> 0 Then
Call copy_range(start_row, end_row)
end_row = 0
End If
Next i
Another approach that lets you only read the character once could be
Dim start_row As Long
Dim end_row As Long
Dim char_above As String
Dim this_char As String
start_row = 1
end_row = 1
For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i, 2) = "" Then
end_row = i - 1
if i <>1 then Call copy_range(start_row, end_row,char_above)
start_row = i + 1
Else
this_char = Left(Cells(i, 2), 1)
If this_char <> char_above Then
end_row = i - 1
if i<> 1 then Call copy_range(start_row, end_row,char_above)
start_row = i
End If
char_above = this_char
End If
Next i
Let me know your thoughts.
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