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
Related
I have different test dates and times that can be up to about 100 tests each time point. I received the data that was only a single column that consists of thousands of rows, which should have been delivered in a matrix type grid.
I have only copied a sample, which has 6 time points and up to 4 tests each. I need Excel to "recognize" when there is only a date/time in a cell, then copy that cell to the next date/time to paste in a new sheet and column.
Eventually, I was hoping to also have the Title of the test separated from the results. However, if this is not plausible without knowing the name of every test, I can skip it. This is the data I start with:
Title
01/02/2010 0:03
Ounces: 10.87
Concentration: 6.89 (L)
Expiration Date: 11/2/2019 5:47:00
01/06/2011 2:06
Ounces: 18.09
Concentration: 10.7 (H)
Expiration Date: 11/2/2019 5:47:00
Other: Resampled
01/06/2011 2:06
Ounces: 12.87
Concentration: 10.9 (H)
Expiration Date: 11/2/2019 5:47:00
Other: 2nd Sample
09/15/2012 7:07
Ounces: 8.53
Concentration: 9.72
Expiration Date: 12/5/2019 4:45:00
05/02/2013 15:52
Ounces: 11.62
Concentration: 8.42
05/09/2017 1:45
Ounces: 9.34
Concentration: 8.98
I created the following Excel VBA, but am still new at programming, especially loops within loops, so I could not figure out how to create the offset that is dynamic enough to both select the right cells, but to copy them over to a new column. I also have redundancy within the code.
Sub Transpose()
Dim dDate As Date
Dim NumberofTasks As Long
Dim x As Long
sSheet = ActiveSheet.Name
Sheets.Add
dSheet = ActiveSheet.Name
With Worksheets("Sheet1")
' All Data is in Column A
NumberofTasks = .Cells(.Rows.Count, "A").End(xlUp).Row
For x = 1 To NumberofTasks
Sheets(sSheet).Activate
If IsDate(.Range("A" & x).Value) Then '<-- check if current cell at Column A is Date
Range(Cells(x, 1), Cells(x, 1).Offset(4, 0)).Select
Selection.Copy
Sheets(dSheet).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
ActiveCell.Offset(1, 0).Select
End If
Next x
End With
End Sub
This is what I hoped would happen (but on a much larger scale):
However, the offset places another date in another cell with the current code. Thank you for any help you can provide me.
There are many ways to skin a cat. Here is one way using arrays which is much much faster than looping through the range
Worksheet:
I am for the sake of coding, assuming that the data is in Sheet1 and looks like below
Logic:
Store the data from the worksheet in an array; Let's call it InputArray
Create an output array for storing data; Let's call it OutputArray
Loop through InputArray and find the date and then find the rest of the records. store in OutputArray
direct the output from OutputArray to the relevant worksheet.
Code:
Option Explicit
Sub Sample()
Dim InputArray As Variant
Dim ws As Worksheet
Dim i As Long
Dim recCount As Long
Dim lRow As Long
Dim OutputArray() As String
'~~> Set relevant input sheet
Set ws = Sheet1
With ws
'~~> Find Last Row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Store col A in array
InputArray = .Range("A1:A" & lRow).Value
'~~> Find Total number of records
For i = LBound(InputArray) To UBound(InputArray)
If IsDate(InputArray(i, 1)) Then recCount = recCount + 1
Next i
'~~> Create an array for output
ReDim OutputArray(1 To 5, 1 To recCount + 1)
recCount = 2
'~~> Fill Col A of output array
OutputArray(1, 1) = "Title"
OutputArray(2, 1) = "Ounces"
OutputArray(3, 1) = "Concentration"
OutputArray(4, 1) = "Expiration Date"
OutputArray(5, 1) = "Other"
'~~> Loop through input array
For i = UBound(InputArray) To LBound(InputArray) Step -1
If IsDate(InputArray(i, 1)) Then '< Check if date
OutputArray(1, recCount) = InputArray(i, 1)
'~~> Check for Ounces and store in array
If i + 1 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 1, 1)), 2)) = "OU" _
Then OutputArray(2, recCount) = Trim(Replace(InputArray(i + 1, 1), "Ounces:", ""))
'~~> Check for Concentration and store in array
If i + 2 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 2, 1)), 2)) = "CO" _
Then OutputArray(3, recCount) = Trim(Replace(InputArray(i + 2, 1), "Concentration:", ""))
'~~> Check for Expiration Date and store in array
If i + 3 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 3, 1)), 2)) = "EX" _
Then OutputArray(4, recCount) = Trim(Replace(InputArray(i + 3, 1), "Expiration Date:", ""))
'~~> Check for Other and store in array
If i + 4 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 4, 1)), 2)) = "OT" _
Then OutputArray(5, recCount) = Trim(Replace(InputArray(i + 4, 1), "Other:", ""))
recCount = recCount + 1
End If
Next i
End With
'~~> Output it to relevant sheet
Sheet2.Range("A1").Resize(5, recCount - 1).Value = OutputArray
End Sub
Output:
I think here is better way to do it using Range.Find
Assuming the Data is in 1st Column of Sheet1 ie. Column A
In Demo the Expiration Date is not right, I have corrected that in the Code.
Try this code:
Sub TP()
Dim wk As Worksheet: Set wk = ThisWorkbook.Worksheets("Sheet1")
Dim lr As Long: lr = wk.Cells(wk.Rows.Count, "A").End(xlUp).row
Dim rng As Range
Dim i As Long
Dim j As Long
j = 4
For i = 3 To lr
Set rng = wk.Range(Cells(i, 1), Cells(i, 1).End(xlDown))
wk.Cells(2, j).Value = rng.Cells(1, 1).Value
Set fnd = rng.Find("Ounces")
If Not fnd Is Nothing Then wk.Cells(3, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
Set fnd = rng.Find("Concentration")
If Not fnd Is Nothing Then wk.Cells(4, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
Set fnd = rng.Find("Expiration")
If Not fnd Is Nothing Then wk.Cells(5, j).Value = Right(fnd.Value, Len(fnd.Value) - Len(Split(fnd.Value, ":")(0)) - 2)
Set fnd = Nothing
Set fnd = rng.Find("Other")
If Not fnd Is Nothing Then wk.Cells(6, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
i = Cells(i, 1).End(xlDown).row + 1
j = j + 1
Next
End Sub
Demo:
May try something like this. Original code was modified and organized to complete the task intended. It takes cares if the other parameters of the test result are not organised in sequence as shown, blank row in between the parameters, no blank row between test results and or missing parameters. It only considers parameters found between rows of two test titles (date time). Takes only 0.5 seconds to process 200 test results from more than 1 K rows.
Option Explicit
Sub Transpose()
Dim dDate As Date
Dim NumberofTasks As Long
Dim x As Long, LastRow As Long, Xval As Variant
Dim srcWs As Worksheet, trgWs As Worksheet
Dim tm As Double
tm = Timer
Set srcWs = ThisWorkbook.ActiveSheet
Set trgWs = ThisWorkbook.Worksheets.Add
trgWs.Cells(1, 1).Value = "Title"
trgWs.Cells(2, 1).Value = "Ounces:"
trgWs.Cells(3, 1).Value = "Concentration:"
trgWs.Cells(4, 1).Value = "Expiration Date:"
trgWs.Cells(5, 1).Value = "Other:"
With srcWs
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
NumberofTasks = 0
x = 1
Do While x <= LastRow
Xval = .Cells(x, 1).Value
If IsDate(Xval) Then
NumberofTasks = NumberofTasks + 1
trgWs.Cells(1, NumberofTasks + 1).Value = .Range("A" & x).Value
ElseIf VarType(Xval) = vbString And NumberofTasks > 0 Then
Xval = Trim(LCase(Xval))
If InStr(1, Xval, "ounces:") > 0 Then
trgWs.Cells(2, NumberofTasks + 1).Value = Trim(Replace(Xval, "ounces:", ""))
ElseIf InStr(1, Xval, "concentration:") > 0 Then
trgWs.Cells(3, NumberofTasks + 1).Value = Trim(Replace(Xval, "concentration:", ""))
ElseIf InStr(1, Xval, "expiration date:") > 0 Then
trgWs.Cells(4, NumberofTasks + 1).Value = Trim(Replace(Xval, "expiration date:", ""))
ElseIf InStr(1, Xval, "other:") > 0 Then
trgWs.Cells(5, NumberofTasks + 1).Value = Trim(Replace(Xval, "other:", ""))
End If
End If
x = x + 1
Loop
End With
'Debug.Print "Seconds "; Timer - tm
End Sub
Tested to produce the result like
this
I am trying to compare data across two sheets in the same workbook. First sheet has a list of individual addresses and the second has a list of address ranges where one column is the starting address range and the second column is the ending address range. for example
sheet1:
123 main st
230 main st
456 main st
Sheet2:
100 200 main st
400 500 main st
How do I find if an individual address falls within an address range? I have the below code that matches on the street name, but I need to add the criteria for the street number falling within that address range, otherwise it's not a match. In this example, sheet1 rows 1 and 3 is a match and sheet1 row 2 is not a match.
Sub matchcolumns()
Dim I, total, fRow As Integer
Dim found As Range
total = Sheets(1).Range("A" & Rows.Count).End(xlUp).row
For I = 2 To total
answer1 = Worksheets(2).Range("A" & I).Value
Set found = Sheets(1).Columns("H:H").Find(what:=answer1) 'finds a match
If Not found Is Nothing Then
Debug.Print "MATCH"
Else
Debug.Print "NO MATCH"
End If
Next I
End Sub
Loop through Sheet1 and check whether it exists in Sheet2. In this instance, MATCH or NO MATCH is written in the third column. Cheers.
Option Explicit
Public Sub check()
Dim vDataSheet As Worksheet
Dim vDataRow As Long
Dim vRefSheet As Worksheet
Dim vRefRow As Long
Dim vFound As Boolean
Set vDataSheet = Application.ActiveWorkbook.Sheets("Sheet1")
Set vRefSheet = Application.ActiveWorkbook.Sheets("Sheet2")
vDataRow = 1
While vDataSheet.Cells(vDataRow, 1) <> ""
vFound = False
vRefRow = 1
While vRefSheet.Cells(vRefRow, 1) <> "" And Not vFound
If vDataSheet.Cells(vDataRow, 1) >= vRefSheet.Cells(vRefRow, 1) And _
vDataSheet.Cells(vDataRow, 1) <= vRefSheet.Cells(vRefRow, 2) And _
vDataSheet.Cells(vDataRow, 2) = vRefSheet.Cells(vRefRow, 3) Then
vFound = True
End If
vRefRow = vRefRow + 1
Wend
If vFound Then
vDataSheet.Cells(vDataRow, 3) = "MATCH"
Else
vDataSheet.Cells(vDataRow, 3) = "NO MATCH"
End If
vDataRow = vDataRow + 1
Wend
End Sub
Sheet1 Before
Sheet2
Sheet1 After
#Mikku thanks I read the data as poorly formatted columns ... not as a single column. My mistake. Here is the updated code to work on single column data. I've made simplistic assumptions on data types (and left street numbers as strings given I've no idea on how they might really be structured) etc ... but works with the data examples used in question:
Option Explicit
Public Sub check()
Dim vDataSheet As Worksheet
Dim vDataRow As Long
Dim vStreetNumber As String
Dim vStreetName As String
Dim vRefSheet As Worksheet
Dim vRefRow As Long
Dim vFromNumber As String
Dim vToNumber As String
Dim vFirstSpace As Long
Dim vSecondspace As Long
Dim vRefName As String
Dim vFound As Boolean
Set vDataSheet = Application.ActiveWorkbook.Sheets("Sheet1")
Set vRefSheet = Application.ActiveWorkbook.Sheets("Sheet2")
vDataRow = 1
While vDataSheet.Cells(vDataRow, 1) <> ""
vStreetNumber = Left(vDataSheet.Cells(vDataRow, 1), InStr(1, vDataSheet.Cells(vDataRow, 1), " ") - 1)
vStreetName = Right(vDataSheet.Cells(vDataRow, 1), Len(vDataSheet.Cells(vDataRow, 1)) - InStr(1, vDataSheet.Cells(vDataRow, 1), " "))
vFound = False
vRefRow = 1
While vRefSheet.Cells(vRefRow, 1) <> "" And Not vFound
vFirstSpace = InStr(1, vRefSheet.Cells(vRefRow, 1), " ")
vFromNumber = Left(vRefSheet.Cells(vRefRow, 1), vFirstSpace - 1)
vSecondspace = InStr(vFirstSpace + 1, vRefSheet.Cells(vRefRow, 1), " ")
vToNumber = Mid(vRefSheet.Cells(vRefRow, 1), vFirstSpace + 1, vSecondspace - vFirstSpace - 1)
vRefName = Right(vRefSheet.Cells(vRefRow, 1), Len(vRefSheet.Cells(vRefRow, 1)) - vSecondspace)
If vStreetNumber >= vFromNumber And vStreetNumber <= vToNumber And _
vStreetName = vRefName Then
vFound = True
End If
vRefRow = vRefRow + 1
Wend
If vFound Then
vDataSheet.Cells(vDataRow, 2) = "MATCH"
Else
vDataSheet.Cells(vDataRow, 2) = "NO MATCH"
End If
vDataRow = vDataRow + 1
Wend
End Sub
Reference data on Sheet2
Matching outcome on Sheet1
Been trying to solve this problem.
I have this sample data to get the rows who are in between Date From and Date to:
Sheet1
This sheet contains Date From: and Date To: cells that will automatically shows the result below
Here's my Sheet2 where the data extracted from
Here's my current VBA code.
Sub FinalData()
Dim lastrow As Long
Dim count As Integer
Dim p As Integer
Dim x As Integer
lastrow = Sheets("Sheet2").Cells(rows.count, 1).End(xlUp).row
Sheets("Sheet1").Range("A5:C1000").ClearContents
count = 0
p = 5
For x = 2 To lastrow
If Sheets("Sheet2").Range("C2:C100") >= Sheets("Sheet1").Cells(1, 2) AND Sheets("Sheet2").Range("C2:C100") <= Sheets("Sheet1").Cells(2, 2) Then
Sheets("Sheet1").Cells(p, 1) = Sheets("Sheet2").Cells(x, 1)
Sheets("Sheet1").Cells(p, 2) = Sheets("Sheet2").Cells(x, 2)
Sheets("Sheet1").Cells(p, 3) = Sheets("Sheet2").Cells(x, 3)
p = p + 1
count = count + 1
End If
Next x
MsgBox " The number of data found for this Area is " & " " & count
End Sub
Is there something wrong with my code? This code works fine from my last project but when I try to use this to get the rows for Date. I think the problem is on the conditional statement that I made.
The problem is you're trying to compare a range of cells with two single cells.
Untested:
Sub FinalData()
Dim lastrow As Long
Dim count As Long
Dim p As Long
Dim x As Long, dt
Dim wsReport As Worksheet, wsData As Worksheet
Set wsReport = ThisWorkbook.Sheets("Sheet1")
Set wsData = ThisWorkbook.Sheets("Sheet2")
lastrow = wsData.Cells(Rows.count, 1).End(xlUp).Row
wsReport.Range("A5:C1000").ClearContents
count = 0
p = 5
For x = 2 To lastrow
dt = wsData.Cells(x, "C")
If dt >= wsReport.Cells(1, 2) And dt <= wsReport.Cells(2, 2) Then
With wsReport
.Cells(p, 1) = wsData.Cells(x, 1)
.Cells(p, 2) = wsData.Cells(x, 2)
.Cells(p, 3) = wsData.Cells(x, 3)
End With
p = p + 1
count = count + 1
End If
Next x
MsgBox " The number of data found for this Area is " & " " & count
End Sub
I have to create a vba script that takes data from a column of another table in Excel ("Days Of Last Update", which is decimal), and then makes a sum based if the day are above 2 (showing the result in a new column).
It seems to be very simple, but I am a beginner and have no idea how to proceed.
UPDATE:
Hello everyone, thanks for the help. Now I have a new problem, still in this project. Here is what I've done:
The RawData's sheet have a column named "Days Since Last Update", that tells me when the Service Request of the product is updated. So, I created a new column with this formula =IF(N:N>2,1,0), to tells me if the Days Since Last Updated are above 2. I refreshed my pivot table to get this new column, did a Sum of the data, and get what I previously wanted, but, when the Update function of the worksheet run, the new column of the pivot table, as well as the column of the RawData with the formula, are gone. In the code (that isn't done by me) of the Update function, there was something like this:
Worksheets("Pivot table").PivotTables("PivotTable1").PivotCache.Refresh
It has something to do with my problem?
Please find the sample data sheet appended below.
VBA Code is appended below.
Sub Extract_Values()
Dim wks As Worksheet
Dim startRow As Integer
Dim lastRow As Integer
Dim vArray As Variant
Dim vNewArray As Variant
Dim i As Integer, j As Integer
Dim Counter1 As Integer, Counter2 As Integer
startRow = 2
Set wks = Sheets("Sheet1")
With wks
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
vArray = .Range("A" & startRow & ":D" & lastRow).Value2
For i = 1 To UBound(vArray)
If vArray(i, 4) = "Y" Then
Counter1 = Counter1 + 1
End If
Next i
ReDim vNewArray(1 To Counter1, 1 To 2)
For j = 1 To UBound(vArray)
If vArray(j, 4) = "Y" Then
Counter2 = Counter2 + 1
vNewArray(Counter2, 1) = vArray(j, 1)
vNewArray(Counter2, 2) = vArray(j, 2)
End If
Next
End With
Range("E" & startRow & ":F" & startRow + Counter1 - 1) = vNewArray
Range("E" & startRow & ":E" & startRow + Counter1 - 1).Select
Selection.NumberFormat = "m/d/yyyy"
Range("F" & startRow + Counter1).Select
End Sub
I am also a beginner setting proper VBA code in cell F8 which I have calculated Excel in-built Count Function.
COLUMN D Contains IF Formula like 'D2=IF(B2>1,"Y","N")'
HTH
Try
Dim RowCount As Integer
Dim NewRow As Integer
RowCount = 2
NewRow = 2
Do Until RowCount > Cells(2, 2).End(xlDown).Row
If Cells(RowCount, 2) > 1 Then
Range(Cells(NewRow, 5), Cells(NewRow, 6)).Value = Range(Cells(RowCount, 1), Cells(RowCount, 2)).Value
NewRow = NewRow + 1
End If
RowCount = RowCount + 1
Loop
End Sub
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