Novice user here, so please bear with me. I am pretty decent with VLOOKUP, but that is about where my expertise ends.
Sheet1 is my active sheet which I am working on.
Sheet2 is my source data.
This sheet contains thousands of lines of client data over the span of the last 6 months.
Each client will currently have anywhere between 1 to 6 unique lines of data within the list (and growing), with the main difference for each client's line being a "date" (1 date per client each month), a "type" (i.e. Trail, Arrears) and a "$ amount".
There are a lot more column than I've mentioned above, so in my active sheet I have already used VLOOKUP to transfer the 3 main columns of data I am using, which are;
"Loan No", "Client Name", "Lender"
Duplicate rows, based on "Loan No" have also been removed. So, now each client just as 1 row.
What I am now trying to do, within each clients unique row, using the original source data, is populate the "$ amount" into a corresponding column, with a month heading, also based on the "Type" value
So basically
Within "Sheet1", look up Loan Number (cell A1) within "Sheet2"
Within "Sheet2", find the row that has both the matching "Loan Number" and matching "Date" (keeping in mind "Sheet1" only has the Month, whereas "Sheet2" has a full DD/MM/YYY)
If this row has a "Type" of "Trail" or "Arrears" (there are other Type fields I want to omit), then
Return the "Amount" to the cell the formula is entered into.
I know there may be multiple ways to do this, but I don't want to mess around with Pivots or anything like that, I also don't want to change the format of the source data. Basic formula is preferred as I am integrating some VBA functions using written formulas etc...
Any help would be greatly appreciated!
Simon
You'll need to adapt this across your worksheets but a SUMIFS should do it for you ...
This is the formula in cell K2 ...
=SUMIFS($F$2:$F$9,$A$2:$A$9,$H2,$D$2:$D$9,">=" & K$1,$D$2:$D$9,"<=" & EOMONTH(K$1,0))
Essentially, it's summing off your data with multiple criteria. You can add additional criteria as need be. The important thing to note here is the dates ...
K1 = 1/07/2021, formatted as ... mmmm ... it must be a date.
L1 = =EDATE(K1,1), formatted as ... mmmm
Make sure you fill across from K1 to N1.
To filter on the dates (i.e. using >= and <=) all fields need to be valid dates.
The dates are important, if they're not dates, then comparing dates (i.e. 1/01/2021) to the words (i.e. January) will not work.
Please, try the next code. It should be fast, using arrays and most of processing is done in memory. It returns in another sheet (shDest), I tested it to return in the next one:
Sub TransposeDataByLenderMonth()
Dim sh As Worksheet, shDest As Worksheet, lastR As Long, minD As Date, maxD As Date, arrD
Dim dict As Object, El, arr, arrFin, i As Long, k As Long, mtch, strD As String
Set sh = ActiveSheet 'use here the sheet you need
Set shDest = sh.Next 'use here the destination sheet (where the processing result to be returned)
'if next one is empty, the code can be used as it is
lastR = sh.Range("A" & sh.rows.Count).End(xlUp).row
minD = WorksheetFunction.min(sh.Range("D2:D" & lastR)) 'find first Date
maxD = WorksheetFunction.Max(sh.Range("D2:D" & lastR)) 'find last date
'create months arrays (one for months header and second to match the date):
arrD = GetMonthsIntArraysl(minD, maxD)
arr = sh.Range("A2:F" & lastR).Value 'place the whole range in an array, for faster iteration
'Extract unique keys by LoanNo:
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
dict(arr(i, 1)) = Empty
Next i
ReDim arrFin(1 To dict.Count + 1, 1 To UBound(arrD(1)) + 4): k = 1
'Place the header in the final array:
arrFin(1, 1) = "LoanNo": arrFin(1, 2) = "Client Name": arrFin(1, 3) = "Lender"
For i = 1 To UBound(arrD(0))
arrFin(1, 4 + i) = CStr(arrD(0)(i, 1))
Next i
k = 2 'reinitialize k to load values after the header
For Each El In dict.Keys 'iterate between the unique elements:
For i = 1 To UBound(arr) 'iterate between the main array rows:
If arr(i, 1) = El Then 'when a match is found:
arrFin(k, 1) = arr(i, 1): arrFin(k, 2) = arr(i, 2): arrFin(k, 3) = arr(i, 3)
strD = CStr(Format(DateSerial(Year(arr(i, 4)), month(arr(i, 4)), 1), "dd/mm/yyyy"))
mtch = Application.match(Replace(strD, ".", "/"), arrD(1), True)
arrFin(k, 4 + mtch) = arr(i, 6) + arrFin(k, 4 + mtch) 'add the value of the appropriate month
End If
Next i
k = k + 1
Next El
'Format a little and drop the processed array content:
With sh.Range("J1").Resize(1, UBound(arrFin, 2))
.NumberFormat = "#"
.BorderAround 1, xlMedium
End With
With sh.Range("J1").Resize(UBound(arrFin), UBound(arrFin, 2))
.Value = arrFin
.EntireColumn.AutoFit
.BorderAround 1, xlMedium
.Borders(xlInsideVertical).Weight = xlThin
End With
MsgBox "Job done..."
End Sub
'The following function returns an array of two arrays.
'One for header and the other for matching the date columns (in the final array)
Private Function GetMonthsIntArraysl(startDate As Date, endDate As Date) As Variant
Dim monthsNo As Long, rows As String, monthsInt, dd As Long, arrStr, arrD
monthsNo = DateDiff("m", startDate, endDate, vbMonday)
rows = month(startDate) & ":" & monthsNo + month(startDate)
arrStr = Evaluate("Text(Date(" & Year(startDate) & ",row(" & rows & "),1),""mmmm YYYY"")")
arrD = Evaluate("Text(Date(" & Year(startDate) & ",row(" & rows & "),1),""dd/mm/yyyy"")")
GetMonthsIntArraysl = Array(arrStr, arrD)
End Function
The above code adds all values for dates belonging to the same months/Client, if the case...
I took your question like a challenge, but you must learn that, in order to receive a solution, you must make some research by your own and show us a piece of code. Please, take it as a favor and next time place a better question, complying to the community rules, from the above mentioned point of view.
Related
I am working on developing a system health check tool to validate that 4 different systems are in sync. To do that, I need to create a sample dataset of random N number of records for every unique key/combination from a main data set everyday. All 4 systems will be checked for records from this sample dataset and any differences will be highlighted using conditional formatting.
I am having trouble figuring out how to extract the sample dataset from the main dataset with the criteria mentioned above.
For Example, I have a report that has 700 rows. Each unique combination (concatenation to create a key) of the 6 fields [Client-Contractor-Distribution Center-Service Level-Alert Value-Status] has 100 records. This part will be dynamic. There could be any number of unique combinations and any number of records per combination. Image below for reference. Only the groups are shown here as I cannot paste 700 records in the question. There are 7 unique groups with 100 records each.
There are some questions in the comments for which I am giving the clarifications below:
-Combination/Group = Basically a key created with concatenation of the focus columns to recognize/define a category the records may belong to. As example concating First Name & Last Name to create a unique identity of a person.
All records will be on a single sheet. It is a report downloaded from a system.
Sequence of the records of each grouping: All records of a particular group will not be bunched together. All records are dumped from the system on the report. We are creating the group/key by concating the focus columns.
Let's say I want 5 random records for each of the 7 GroupKeys. Essentially, I need a way to get 35 records that are randomly selected, 5 per unique combination.
A sample of the desired output is shown below.
I have tried using RAND() and RANDBETWEEN() formulas. I do get random records. But the problem is that I cannot ensure that I get 5 records per combination and sometimes duplicate records are returned as well. I am open to any method (VBA/Formulas) to achieve this.
This is a very complex problem for someone like me who is only a novice/beginner at VBA at most.
Please, test the next code. It needs a reference to 'Microsoft Scripting Runtime':
Sub RandomRecPerGroup()
Dim sh As Worksheet, shRet As Worksheet, lastR As Long, dict As New Scripting.Dictionary
Dim arr, arrIt, i As Long, j As Long, f As Long, k As Long, count As Long, arrFin
Set sh = ActiveSheet 'use here the sheet you need
Set shRet = sh.Next 'use here the sheet you need (for testing reason, the next against the active one)
shRet.Range("G1").EntireColumn.NumberFormat = "#" 'format the column to keep 'Reference number' as text
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
arr = sh.Range("A2:G" & lastR).Value ' place the range in an array for faster iteration
ReDim arrFin(1 To 5, 1 To 7): k = 1 'reDim the array to keep each group
For i = 1 To UBound(arr) 'iterate between the array elements:
'create a dictionary key if not already existing, with the number of the row as item:
If Not dict.Exists(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)) Then
dict.Add arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6), i
Else 'adding the number of row, separated by "|"
dict(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)) = _
dict(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)) & "|" & i
End If
Next i
Dim rndNo As Long 'a variable to receive the random number
For i = 0 To dict.count - 1 'iterate between the dictionary elements:
arrIt = Split(dict.items(i), "|"): ' split the item by "|" to obtain the same group existing rows
For k = 1 To 5 'iterate to extract the 5 necessary sample rows of each group
Randomize 'initialize the random numbers generation
If UBound(arrIt) = -1 Then Exit For 'for the case of less than 5 rows per group
rndNo = CLng(UBound(arrIt) * Rnd()) 'give a value to the variable keeping the random numbers
For f = 1 To 7 'iterating to place in the array all 7 columns value
arrFin(k, f) = arr(arrIt(rndNo), f)
Next f
arrIt = Filter(arrIt, arrIt(rndNo), False) 'eliminate the element just placed in an array, to avoid doubling
Next k
lastR = shRet.Range("A" & sh.rows.count).End(xlUp).row + 1 'last empty row of the sheet where the result is returned
shRet.Range("A" & lastR).Resize(5, 7).Value = arrFin 'drop the array content
Next i
MsgBox "Ready..."
End Sub
The code may work without the mentioned reference (using labe binding), but I think it should be good to benefit of intellisense suggestions. If it looks complicated to create it, please (firstly) run the next code which will add it automatically:
Sub addScrRunTimeRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
If err.Number = 32813 Then
err.Clear: On Error GoTo 0
MsgBox "The reference already exists...": Exit Sub
Else
On Error GoTo 0
MsgBox """Microsoft Scripting Runtime"" reference added successfully..."
End If
End Sub
Saving the workbook will keep the reference. So, no need to run the code again...
So basically you have 700 possibilities, and you want to get 5 random values out of them, while you are sure that you don't have duplicates?
There are, basically, two ways to do this:
You make a resulting collection of random values, you use the random generator to generate numbers from 1 to 700, but before adding them to your collection, you verify if they are already present in your collection. Something like (pseudo-code):
Dim col_Result as Collection
Dim finished as Boolean = False;
Dim r as integer;
while (not finished){
r = ConvertToInt(Random(700)) + 1;
if not(col_Result.Contains(r))
then col_Result.Add(r);
finished = (col_Result.Count == 5);
}
You make a collection of all numbers from 1 to 700, and 5 times you retrieve a random value out of it, while subtracting that value from the collection. Something like (pseudo-code again):
Dim col_Values as Collection = (1, 2, ..., 700);
Dim col_Result as Collection;
Dim r as integer;
for (int i = 0; i < 5; i++){
r = ConvertToInt(Random(700));
col_Result.Add(r);
col_Values.Subtract(r);
}
When using this last approach, it is vital that subtracting a value from the collection shifts the other values: (1,2,3,4,5).Subtract(2) yields (1,3,4,5).
I have a table that looks like this:
Basically, "MatGroup" is a subtype of "StorLoc" which is a subtype of "Department".
I need to look for a match in those three columns, then return the values of two of the other columns to the right (those columns represent weeks).
I've highlighted an example in the picture above. There I'm searching for Department 1101, StorLoc 0001 and MatGroup 1225 in week 4 and 5, which should return the values 243 and 245, which can then be added together = 488.
For testing purpose, I have a working formula that does this in the same worksheet:
=SUMPRODUCT(XLOOKUP(K6&J8&K7;A2:A40&B2:B40&C2:C40;D2:E40))
However, I need a pure VBA solution for this as I'll be pulling this data into a completely separate workbook. I'm not able to use the same solution as in the formula above because apparantly VBA does not allow you to concat multiple criteria with &.
My current solution of using tons of CountIfs is not exactly satisfying and completely a lot more resource intensive than necessary (and messy!):
resultCount = Application.WorksheetFunction.SumIfs(dataWorkBook.Range("A" & departmentStartRow & ":BC" & departmentEndRow).Columns(weekNumber + 1), dataWorkBook.Range("B" & departmentStartRow & ":B" & departmentEndRow), StorLoc, dataWorkBook.Range("C" & departmentStartRow & ":C" & departmentEndRow), MatGroup)
Please, try the next code. It uses an array and should be very fast even for big ranges, working in memory:
Sub LookupThreeConditions()
Dim sh As Worksheet, sh1 As Worksheet, lastRow As Long, arr, i As Long
Dim dep As String, stLoc As String, matGr As String, result As Long
dep = "1101": stLoc = "0001": matGr = "1225"
Set sh = ActiveSheet
Set sh1 = sh.Next 'use here the sheet you need to copy in
lastRow = sh.Range("A" & sh.rows.Count).End(xlUp).row
arr = sh.Range("A2:F" & lastRow).value 'put the range in an array
For i = 1 To UBound(arr)
If arr(i, 1) & arr(i, 2) & arr(i, 3) = dep & stLoc & matGr Then
result = arr(i, 5) + arr(i, 6): Exit For
End If
Next i
MsgBox "Result is " & result
sh1.Range("A1").value = result 'use here what range you need
End Sub
I have alphanumeric text in a column in Excel. I need to sort them in alphabetic order and also numerically.
The only way I could do this is by extract number to another column and then sort it, but it is not feasible for me as there same number may occur multiple times, there maybe multiple brackets and i need them to sort in alphabetic order too. I would like to know the VBA code also to automate this.
As you can see in the below image with A to Z sorting, "A05 [1][21]" came between "A05 [1][2]" & "A05 [1][3]", but I want it to be numerical order as shown in expected result..
Natural Sort via splitting
This approach
[1] assigns data to a "vertical" 2-dim array with two columns,
[2] enters a 2nd criteria column with numeric bracket values via Split() function and executes a bubble sort and
[3] writes the sorted data back to the original range.
Sub ExampleCall()
'[0]define data range (starting at 2nd row in column A:A)
With Sheet1 ' << change to project's sheet Code(Name)
Dim lastrow As Long: lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim rng As Range: Set rng = .Range("A2:A" & lastrow)
End With
'[1]assign data to datafield array
Dim data: data = rng.Resize(, 2)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[2]calculate sort criteria and sort data
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FillSortCriteria data ' << run procedure FillSortCriteria
NaturalSort data ' << run procedure NaturalSort
'[3]write results
'rng.Offset(, 1) = data ' (optional insertion into next column)
rng = data ' overwrite range
End Sub
Help procedure FillSortCriteria
Sub FillSortCriteria(arr)
'Purpose: calculate criteria in 2nd column of 2-dim array
Dim i As Long
For i = LBound(arr) To UBound(arr)
Dim tokens: tokens = Split(arr(i, 1) & "[[", "[")
arr(i, 2) = Left(tokens(0) & String(10, " "), 10) & _
Format(Val(tokens(1)), "000") & "." & _
Format(Val(tokens(2)), "000")
Next i
End Sub
Further hints
Splitting a string like "A05-i [1][21]" by delimiter "[" results in a zero-based array where the first token, i.e. token(0) equals "A05-i", the 2nd "1]" and the 3rd "21]". The Val() function converts the bracket items to a numeric value ignoring non-numeric characters to the right.
These tokens can be joined to a sortable criteria in the second column of the passed array; as the arr argument has been passed ByReference by default thus referring to the data array in the calling procedure, all entries change immediately the referring data entries.
Help procedure NaturalSort (modified Bubblesort)
Sub NaturalSort(arr)
'Purpose: natural sort of 2nd and 3rd token (numbers in brackets)
'Note: assumes "vertical" 2-dim array holding criteria in 2nd column
Dim cnt As Long, nxt As Long, temp, temp2
For cnt = LBound(arr) To UBound(arr) - 1
For nxt = cnt + 1 To UBound(arr)
If arr(cnt, 2) > arr(nxt, 2) Then
temp = arr(cnt, 1): temp2 = arr(cnt, 2)
arr(cnt, 1) = arr(nxt, 1): arr(cnt, 2) = arr(nxt, 2)
arr(nxt, 1) = temp: arr(nxt, 2) = temp2
End If
Next nxt
Next cnt
End Sub
The excel file for dates of duties taken by persons are as shown in figure. Marked duties as X
How can I get the date of duties taken by a particular person using filtering?
Is there any method to get each person's name together with their duty date in a separate sheet?
I think what you're trying to do is:
Unpivot:
Select the data and on the Insert menu choose Table
On the Data menu click From Table/Range
The query window will open. Choose the columns you need to extract. With your data the columns to highlight are "Type" and "Number of Cases"
On the Tranform menu choose Unpivot Columns
If the data looks right now, close the Query Editor (accepting changes).
Another example:
If your goal is to get from this:
...to this (or that):
...then what you want to do is called an Unpivot.
How to Unpivot "crosstab-style" data:
You can find the steps written out on a question I answered here, and there's a more detailed explanation and steps over here.
Approach via array filtering
You need filter results row wise (e.g. Tessy Paul- 26 April 18, 27 April 18, 30 April 18, 2-May 18), but IMO you won't get them via advanced filter method. Instead I demonstrate an alternative approach using arrays to get the source data (looping through a range via VBA is slow) and to extract the rearranged (=recoded) data via Application.Filter matching items marked by "x" as duty.
Essential steps
First you write all your data to a variant 2-dimensioned datafield array simply by assigning a predefined range reference - see section [2]:
Dim v As Variant ' or simply: Dim v
Dim rng As Range
'set rng = ...
v = rng.Value2 ' or simply: v = rng
Furthermore it's possible to filter an array via Application.Filter with some restrictions:
a) you'll need some further information beyond the isolated cell data and
b) you'll need a 1-dim array.
ad a) In order to identify name and duty date when filtering, just add these information together with a delimiter (e.g. "#", see section [3]).
This allows you to split the filtered data later by looping through each array item - see sections [4] and [5].
ad b) To get a 1-dim array out of a 2-dim array you can extract a row or a column via Application.Index function.
In the example below I assign results to another array called vi.
For example: if you want to extract a row as shown in section 4.1, the second parameter identifies the row number starting from 1, the third argument column number simply obtains 0 :
Then you can apply the Filter function with this newly dimensioned source array and a match string "x#" to get all data defined as Duty by the x character and the chosen delimiter #.
vi = VBA.filter(Application.Index(v, i, 0), "x#", True, False)
Notes:
The match string consists of both characters ("x#"), as "x" alone could be part of a name (e.g. Alexander), too.
As an addition to row wise filtering:
To extract a column see section 5.1, as this needs an additional adjusting via Application.Transpose.
Each extracted row or column array will be written back to a target sheet and shown via Join function in Debug.Print in your immediate window in the Visual Basic Editor (VBE)
Code Example
Option Explicit
Sub DutiesPerName()
' Site: https://stackoverflow.com/questions/50083149/how-can-i-use-advance-filtering-row-wise
' [0] Declare variables
Dim a()
Dim ws As Worksheet, ws2 As Worksheet
Dim rng As Range, i As Long, j As Long, r As Long, c As Long
Dim v, vi, temp
' [1] define sheetname and data range
' 1.0 set worksheet object to memory
Set ws = ThisWorkbook.Worksheets("MyDataSheet") ' << change to your data sheet name
Set ws2 = ThisWorkbook.Worksheets("MyDutySheet") ' << change to your target sheet name
' 1.1 get rows and columns
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
c = ws.Range("A1").End(xlToRight).Column
' 1.2 Alternative code line: Set rng = ws.UsedRange
Set rng = ws.Range(ws.Range(ws.Cells(1, 1), ws.Cells(r, c)).Address)
' [2] create a variant 1-based 2-dim datafield array
v = rng.Value2
' [3] CODE duty items by appending "#" plus date and name info
For i = 2 To UBound(v) ' start loop from 2nd row
v(i, 1) = "x#" & v(i, 1) ' mark name captions to get them filtered, too
For j = 3 To UBound(v, 2) ' start inner loop from 3rd column
If v(i, j) = "x" Then ' code found duty items
v(i, j) = v(i, j) & "#" & Format(v(1, j), "dd-mmm-yy") & "#" & v(i, 1) & "#" & j
'Debug.Print "v(" & i & "," & j & ")=""" & v(i, j) & """"
End If
Next j
Next i
' mark date captions with "x#" to get them filterd, too
For j = 3 To UBound(v, 2)
v(1, j) = "x###" & Format(Val(v(1, j)), "dd-mmm-yy")
Next j
' -----------------------
' [4] Duty Dates per Name:
' -----------------------
ws2.Cells.Clear: ws2.Range("A1") = "Name": ws2.Range("B1") = "Duty Dates ..."
For i = 2 To UBound(v, 1) ' start loop from 2nd row
' 4.1 filter redimensioned 1-dim ROW array via "x#"
vi = VBA.filter(Application.Index(v, i, 0), "x#", True, False)
For j = LBound(vi) To UBound(vi)
vi(j) = Split(vi(j), "#")(1) ' extracts date from e.g. "x#15-Jan-19#x#Paul#2"
Next j
' write dates per name into target worksheet ws2
ws2.Range("A1").Offset(i - 1, 0).Resize(1, UBound(vi) + 1) = vi
Debug.Print "Row# " & i & " (" & _
ws2.Range("A1").Offset(i - 1, 0).Resize(1, UBound(vi) + 1).Address & ") 1 Name + " & UBound(vi) & " Dates: " & _
Join(vi, ", ")
Next i
Debug.Print
' -----------------------
' [5] Names per Duty Date:
' -----------------------
ws2.Range("A1").Offset(r + 2, 0) = "Duty Date": ws2.Range("A1").Offset(r + 2, 1) = "Names ..."
For i = 3 To UBound(v, 2) ' start loop from 3rd column
' 5.1 filter redimensioned 1-dim COLUMN array via "x#"
vi = VBA.filter(Application.Transpose(Application.Index(v, 0, i)), "x#", True, False)
For j = LBound(vi) To UBound(vi)
temp = Split(vi(j), "#")
vi(j) = temp(3) ' extracts Name from e.g. "x#15-Jan-19#x#Albert#3"
Next j
' write each names per date into target worksheet ws2
If UBound(vi) > -1 Then
ws2.Range("A1").Offset(r + i, 0).Resize(1, UBound(vi) + 1) = vi
Debug.Print "Col# " & i & " (" & _
ws2.Range("A1").Offset(r + i, 0).Resize(1, UBound(vi) + 1).Address & ") 1 Date + " & UBound(vi) & " Names: " & _
Join(vi, ", ")
End If
Next i
End Sub
Good afternoon all,
I have an issue where I have users who have multiple bank account details. I need to try and create a new row for each employee who has more than one bank account, with the second bank account being allocated a new row.
Employee Number User ID BSB Account number
10000591 WOODSP0 306089,116879 343509,041145273
10000592 THOMSOS0 037125 317166
I need it to look something like this:
Employee Number User ID BSB Account number
10000591 WOODSP0 306089 343509
10000591 WOODSP0 116879 041145273
10000592 THOMSOS0 037125 317166
Any thoughts? Your input is greatly appreciated!
Screenshots are here to demonstrate:
Right click on the tab and choose "View Code"
Paste this code in:
Sub SplitOnAccount()
Dim X As Long, Y As Long, EmpNo As String, UserID As String, BSB As Variant, AccNo As Variant
Range("F1:I1") = Application.Transpose(Application.Transpose(Array(Range("A1:D1"))))
For X = 2 To Range("A" & Rows.Count).End(xlUp).Row
EmpNo = Range("A" & X).Text
UserID = Range("B" & X).Text
BSB = Split(Range("C" & X).Text, ",")
AccNo = Split(Range("D" & X).Text, ",")
For Y = LBound(AccNo) To UBound(AccNo)
Range("F" & Range("F" & Rows.Count).End(xlUp).Row).Offset(1, 0).Formula = EmpNo
Range("G" & Range("G" & Rows.Count).End(xlUp).Row).Offset(1, 0).Formula = UserID
Range("H" & Range("H" & Rows.Count).End(xlUp).Row).Offset(1, 0).Formula = BSB(Y)
Range("I" & Range("I" & Rows.Count).End(xlUp).Row).Offset(1, 0).Formula = AccNo(Y)
Next
Next
End Sub
Close the window to go back to excel
Press ALT-F8
Choose SplitOnAccount and click run.
Note, this is going to populate the split data to rows F to I, make sure there is nothing in there. If there is post back and we can change it.
Also format columns F - I as text before you run it or Excel will strip leading zeros off as it will interpret it as a number.
Here is another sub that appears to perform what you are looking for.
Sub stack_accounts()
Dim rw As Long, b As Long
Dim vVALs As Variant, vBSBs As Variant, vACTs As Variant
With ActiveSheet '<-define this worksheet properly!
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
vVALs = .Cells(rw, 1).Resize(1, 4).Value
vBSBs = Split(vVALs(1, 3), Chr(44))
vACTs = Split(vVALs(1, 4), Chr(44))
If UBound(vBSBs) = UBound(vBSBs) Then
For b = UBound(vBSBs) To LBound(vBSBs) Step -1
If b > LBound(vBSBs) Then _
.Rows(rw + 1).Insert
.Cells(rw - (b > LBound(vBSBs)), 1).Resize(1, 4) = vVALs
.Cells(rw - (b > LBound(vBSBs)), 3).Resize(1, 2).NumberFormat = "#"
.Cells(rw - (b > LBound(vBSBs)), 3) = CStr(vBSBs(b))
.Cells(rw - (b > LBound(vBSBs)), 4) = CStr(vACTs(b))
Next b
End If
Next rw
End With
End Sub
I was originally only going to process the rows that had comma delimited values in columns C and D but I thought that processing all of them would allow the macro to set the Text number format and get rid of the Number as text error warnings and keep the leading zero in 041145273.
You Can definitely use Power Query to transform the data to generate new rows using split column option.
Check this article it explains the process in detail.
Load Data in Power Query section of excel.
Create an Index (Not required step)
Use Split column function with advance options and split them into new rows.
Save this result into new table for your use.
I did it myself and it worked like a charm.
A formula solution:
Delimiter: Can be a real delimiter or an absolute reference to a cell containing only the delimiter.
HelperCol: I have to use a helper column to make it work. You need to give the column letter.
StartCol: The column letter of the first column containing data.
SplitCol: The column letter of the column to be splitted.
Formula1: Used to generate the formula for the first column not to be splitted. You can fill this formula down and then fill to right.
Formula2: Used to generate the formula for the column to be splitted(only support split one column).
Formula3: Used to generate the formula for the Helper column.
(If the title of the column to be splitted contains the delimiter, you must change the first value of the helper column to 1 manually.)
Formula1:=SUBSTITUTE(SUBSTITUTE("=LOOKUP(ROW(1:1),$J:$J,A:A)&""""","$J:$J","$"&B2&":$"&B2),"A:A",B3&":"&B3)
Formula2:=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE("=MID($M$1&LOOKUP(ROW(A1),$J:$J,F:F)&$M$1,FIND(""艹"",SUBSTITUTE($M$1&LOOKUP(ROW(A1),$J:$J,F:F)&$M$1,$M$1,"&"""艹"",ROW(A2)-LOOKUP(ROW(A1),$J:$J)))+1,FIND(""艹"",SUBSTITUTE($M$1&LOOKUP(ROW(A1),$J:$J,F:F)&$M$1,$M$1,""艹"",ROW(A2)-LOOKUP(ROW(A1),$J:$J)+1))-FIND(""艹"",SUBSTITUTE($M$1&LOOKUP(ROW(A1),$J:$J,F:F)&$M$1,$M$1,""艹"",ROW(A2)-LOOKUP(ROW(A1),$J:$J)))-1)&""""","$M$1",IF(ISERROR(INDIRECT(B1)),""""&B1&"""",B1)),"$J:$J","$"&B2&":$"&B2),"F:F",B4&":"&B4)
Formula3:=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE("=SUM(E1,LEN(B1)-LEN(SUBSTITUTE(B1,$H$1,"""")))+1","B1",B4&1),"$H$1",IF(ISERROR(INDIRECT(B1)),""""&B1&"""",B1)),"E1",B2&1)
Helper must filled one row more than the data.
How to use:
Copy the formula generated by the above three formula.
Use Paste Special only paste the value.
Make the formula into effect.
Fill the formula.
Bug:
Numbers will be converted to Text. Of course you can remove the &"" at the end of the formula, but blank cells will be filled with 0.
ps. This method may by very hard to comprehend. But once you master it, it can be very useful to solve relative problems.