I'm trying to create a macro that outputs all possible permutations starting with a column of some numbers where each consecutive number can't be greater than the number above it.
So, would I would like to do is to provide excel with a column of 15 values in Sheet1 ranging from 1 to 9. The values should be in descending order so that a number on a row below can never exceed the one above.
What I am trying to do is to output new permutations of this list, one new sheet per new list.
The upper limit of the values in the list would be specified so the number of permutations would be everything between the starting list and the upper limit value.
There is a condition that I can not break and that is that the value of a row below another row, can't have a greater value than the one above. There's an image that explains a bit.
So far my code is not even half way there and I feel completely lost.
I'm not even sure how to go about thinking about this problem let alone coding it.
Any input would be greatly appreciated.
Sub
doSomeStuff()
Dim maxNotch, startNotch, Counter As Integer
Dim shit As Range
maxNotch = 3
startNotch = ThisWorkbook.Sheets("Sheet1").Cells(2, 2)
Counter = startNotch
sheetnumber = 2
For j = st
artNotch To maxNotch
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Sheet" & sheetnumber
ThisWorkbook.Sheets("Sheet" & sheetnumber).Cells(2, 2).Value = Counter
For i = 1 To 3
ThisWorkbook.Sheets("Sheet" & sheetnumber).Cells(i + 1, 1).Value = 2 + i
If ThisWorkbook.Sheets("Sheet" & sheetnumber).Cells(i + 1, 2).Value <> Counter Then
k = Counter - ThisWorkbook.Sheets("Sheet" & sheetnumber - 1).Cells(i + 1, 2).Value
Debug.Print k
End If
Next i
sheetnumber = sheetnumber + 1
Counter = Counter + 1
Next j
Application.DisplayAlerts = True
End Sub
Function pop()
(ByVal j As Integer, k As Integer)
For i = 1 To 3
ThisWorkbook.Sheets("Sheet" & j + 1).Cells(i + 1, 1).Value = 2 + i
ThisWorkbook.Sheets("Sheet" & j + 1).Cells(2, 2).Value = Counter
If ThisWorkbook.Sheets("Sheet" & j + 1).Cells(i + 1, 2).Value <> Cou
nter Then
ThisWorkbook.Sheets("Sheet" & j + 1).Cells(i + 1, 2).Value = ThisWorkbook.Sheets("Sheet" & j).Cells(i + 1, 2).Value
End If
Next i
End Function
Example from my comment, to account for the ordering:
dim pc as long, ws as worksheet
for each ws in worksheets
with ws
If ws.name <> "sourcedatasheet" then
.cells(2,2).resize(pc).value = "" 'export your list; pc = permutation count
.Range(.Cells(1,2),.Cells(pc+1,2)).Sort key1:=.Cells(1,2), order1:=xlDescending, Header:=xlYes 'used a header because row 1 is blank
end if
end with
next
Edit1:
Adding an if-statement to account for some specific sheet to not be included
Related
The project consist to add lines in a new table based on value coming from 2 different table (or Excel file).
There are 3 files, called by :
Reference : the content of the file will not change
Data : the content of the file will always change
Result : the content of the file is a combination of the Reference and Date based on my request below. It is want I need.
I create 3 files, all manually with some value in order to help you to understand, called Example_Reference, Example_Data and Example_Result.
What as to be done:
First step:
Write a new line (in the new file/table) and copy exactly all the cells of the first line of Reference file.
Second step:
We take the content of the cell (column A) of Reference file (same line that point 1.) and we look in the Data file if one cell at least (column A) is the exactly the same :
a. If NOT : Do nothing, and continue for next line of the Reference file (do that until end of line of the Reference line (not end of Excel, but when no more line with something inside))
b. If YES :
i. Look how many line are with the same value (text) in the column A (Data file), create (in the Result file) a number of line equal to the number of same value and copy all data and line from Data file (for the same Column A of course).
ii. Modify in the first line (created on point 1) the cell (column R) with the different value of the column R added in point 2.b. of each line with specific “;” as in example. (T1;T2;T3… if T1 T2 and T3 are on the line).
iii. For main line (where a Product is written, like in the Reference file and line), on column N, it should be the sum of all the number below (0, 3 or 😎 for all the subline (Variant).
3. If sum = 0, write FALSE on column K. If sum is different from 0, write on column K TRUE.
c. Do that until we finish to read all the line of the Reference
Below are the Images of example three files:
Reference
Data
Result
So far I have done with the First Step as follows:
Dim cel As Range
Dim oFoundRng As Range
Range("A1").End(xlUp).Select ' looking for first empty cell on result sheet
With Workbooks("Example_Reference").Worksheets("Feuil1")
With .Range("a1", .Cells(.Rows.Count, "a").End(xlUp))
For Each cel In .SpecialCells(xlCellTypeConstants) ' loop through referenced range not empty cells
.Range(cel.Address).EntireRow.Copy Workbooks("result").Worksheets("feuil1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next
End With
End With
Now I need to take the content of the cell (column A) of Reference file (same line that point 1.) and we look in the Data file if one cell at least (column A) is the exactly the same.
can you guys help?
I will update my question as I go along ...
Here you have, let me know if works as you expected :)
Just set the workbook variables with your names or paths.
The sub is ready to work with the three workboos already opened but if
you want the macro to open the wbks just add workbooks.open method at the beginning.
Sub ProcessData()
'Workbook ans worksheet declaration
Dim referenceWbk As Workbook
Set referenceWbk = Workbooks("Reference.xlsx")
Dim dataWbk As Workbook
Set dataWbk = Workbooks("Data.xlsx")
Dim exampleWbk As Workbook
Set exampleWbk = Workbooks("Example.xlsm")
Dim referenceWsh As Worksheet
Set referenceWsh = referenceWbk.Sheets(1)
Dim dataWsh As Worksheet
Set dataWsh = dataWbk.Sheets(1)
Dim exampleWsh As Worksheet
Set exampleWsh = exampleWbk.Sheets(1)
'Loop reference workbook
Dim exampleLastRow As Long: exampleLastRow = 1
Dim i As Long
For i = 1 To referenceWsh.Range("A" & referenceWsh.Rows.Count).End(xlUp).Row
referenceWsh.Range("A" & i).EntireRow.Copy
exampleWsh.Range("A" & exampleLastRow).PasteSpecial xlPasteValues
'loop data wsh
Dim coicidenceCount As Long: coicidenceCount = 0
'Delete header in column N, R and K
exampleWsh.Range("N" & exampleLastRow).Value = ""
exampleWsh.Range("R" & exampleLastRow).Value = ""
exampleWsh.Range("K" & exampleLastRow).Value = ""
Dim j As Long
For j = 1 To dataWsh.Range("A" & dataWsh.Rows.Count).End(xlUp).Row
If dataWsh.Range("A" & j).Value = exampleWsh.Range("A" & exampleLastRow).Value Then
coicidenceCount = coicidenceCount + 1
exampleWsh.Range("A" & exampleLastRow + coicidenceCount).Value = dataWsh.Range("A" & j).Value
exampleWsh.Range("R" & exampleLastRow + coicidenceCount).Value = dataWsh.Range("B" & j).Value
exampleWsh.Range("N" & exampleLastRow + coicidenceCount).Value = dataWsh.Range("C" & j).Value
exampleWsh.Range("B" & exampleLastRow + coicidenceCount).Value = "Variant"
'add value to R header (plus ';')
exampleWsh.Range("R" & exampleLastRow).Value = exampleWsh.Range("R" & exampleLastRow).Value & dataWsh.Range("B" & j).Value & ";"
'add value to N header
exampleWsh.Range("N" & exampleLastRow).Value = exampleWsh.Range("N" & exampleLastRow).Value + dataWsh.Range("C" & j).Value
End If
Next j
'add value to K header
If exampleWsh.Range("N" & exampleLastRow).Value > 0 Then
exampleWsh.Range("K" & exampleLastRow).Value = True
Else
exampleWsh.Range("K" & exampleLastRow).Value = False
End If
'delete last ';' from R header
If exampleWsh.Range("R" & exampleLastRow).Value <> "" Then
exampleWsh.Range("R" & exampleLastRow).Value = Left(exampleWsh.Range("R" & exampleLastRow).Value, Len(exampleWsh.Range("R" & exampleLastRow).Value) - 1)
End If
exampleLastRow = exampleWsh.Range("A" & exampleWsh.Rows.Count).End(xlUp).Row + 1
Next i
End Sub
Try the next code, please. We cannot see which is the last column of 'Reference' sheet, but looking to the 'Result' one I assumed that it should be column "Q:Q":
Sub testProcessThreeWorkbooks()
Dim wsRef As Worksheet, wsData As Worksheet, wsRes As Worksheet
Dim lastRR As Long, lastRD As Long, rowRes As Long, i As Long, j As Long
Dim count As Long, k As Long, arr, arrT
Set wsRef = Workbooks("Example_Reference.xlsx").Sheets(1) 'use here the necessary sheet
Set wsData = Workbooks("Example_Data.xlsx").Sheets(1) 'use here the necessary sheet
Set wsRes = Workbooks("Example_Result.xlsx").Sheets(1) 'use here the necessary sheet
lastRR = wsRef.Range("A" & rows.count).End(xlUp).row 'last row of 'Reference` sheet
lastRD = wsData.Range("A" & rows.count).End(xlUp).row 'last row of 'Data' sheet
rowRes = 1 'Row of the 'Result' sheet, where the first processed line should be placed
For i = 1 To lastRR 'iterate between all existing cells of A:A 'Reference' sheet column
wsRes.Range("A" & rowRes).Resize(1, 17).Value = wsRef.Range("A" & i, "Q" & i).Value 'copy the row to be processed
count = WorksheetFunction.CountIf(wsData.Range("A1:A" & lastRD), wsRef.Range("A" & i).Value) 'count the occurrences
If count > 0 Then 'if any occurence exists:
ReDim arrT(count - 1) 'redim the array keeping 'T' type data
ReDim arr(count - 1) 'redim the array to keep the values from C:C column
k = 0 'initialize the variable to fill in the above arrays
For j = 1 To lastRD 'iterate between all existing cells of A:A 'Data' sheet column
If wsRef.Range("A" & i).Value = wsData.Range("A" & j).Value Then 'for occurrences:
arrT(k) = wsData.Range("B" & j).Value 'load 'T' type values
arr(k) = wsData.Range("C" & j).Value: k = k + 1 'Load values of C:C column
End If
Next j
With wsRes 'process the 'Result' range:
.Range("R" & rowRes).Value = Join(arrT, ";") 'place the string in column R:R
.Range("A" & rowRes + 1 & ":A" & rowRes + count).Value = wsRef.Range("A" & i).Value 'copy the 'Codes'
.Range("B" & rowRes + 1 & ":B" & rowRes + count).Value = "Variant" 'write 'Variant'
.Range("N" & rowRes + 1).Resize(UBound(arr) + 1, 1).Value = WorksheetFunction.Transpose(arr) 'drop the array values
.Range("N" & rowRes).Formula = "=Sum(N" & rowRes + 1 & ":N" & rowRes + count & ")" 'sumarize the values of N:N col
'Evaluate the value in N:N and place 'TRUE' or 'FALSE' accordingly:
If .Range("N" & rowRes).Value = 0 Then .Range("K" & rowRes).Value = False Else: .Range("K" & rowRes).Value = True
End With
End If
rowRes = rowRes + count + 1: count = 0 'reinitialize the necessary variables
Next i
End Sub
If big files/ranges are involved, I can prepare a faster solution using arrays instead of all ranges.
Edited
I found some time and prepared the faster version, using only arrays, all processing being done in memory:
Sub testProcessThreeWorkbooksArrays()
Dim wsRef As Worksheet, wsData As Worksheet, wsRes As Worksheet
Dim lastRR As Long, lastRD As Long, rowRes As Long, i As Long, j As Long
Dim count As Long, k As Long, arrRef, arrDat, arrRes, arrSlice, arr, arrT
Dim m As Long, sumV As Double
Set wsRef = Workbooks("Example_Reference.xlsx").Sheets(1) 'use here the necessary sheet
Set wsData = Workbooks("Example_Data.xlsx").Sheets(1) 'use here the necessary sheet
Set wsRes = Workbooks("Example_Result.xlsx").Sheets(1) 'use here the necessary sheet
lastRR = wsRef.Range("A" & rows.count).End(xlUp).row 'last row of 'Reference` sheet
lastRD = wsData.Range("A" & rows.count).End(xlUp).row 'last row of 'Data' sheet
arrRef = wsRef.Range("A1:Q" & lastRR).Value
arrDat = wsData.Range("A1:C" & lastRD).Value
ReDim arrRes(1 To 18, 1 To UBound(arrRef) + UBound(arrDat))
rowRes = 1 'Row of the 'Result' sheet, where the new processed line should be placed
For i = 1 To UBound(arrRef) 'iterate between all existing 'arrRef' array rows
arrSlice = Application.Index(arrRef, i, 0) 'extract a slice of the row number i
'Place the slice values in the arrRes appropriate row:
For m = 1 To UBound(arrSlice): arrRes(m, rowRes) = arrSlice(m): Next m
arrSlice = Application.Index(arrDat, 0, 1) 'extract a slice of the 'arrDat' first column
For m = 1 To UBound(arrSlice)
If arrSlice(m, 1) = arrRef(i, 1) Then count = count + 1 'extract number of occurrences
Next m
If count > 0 Then 'if any occurence exists:
ReDim arrT(count - 1) 'redim the array keeping 'T' type data
ReDim arr(count - 1) 'redim the array to keep the values from C:C column
k = 0 'initialize the variable to fill in the above arrays
For j = 1 To UBound(arrDat) 'iterate between all 'arrDat' array rows:
If arrRef(i, 1) = arrDat(j, 1) Then 'in case of occurrences:
arrT(k) = arrDat(j, 2) 'load 'T' type values
arr(k) = arrDat(j, 3): k = k + 1 'Load values of C:C column
End If
Next j
arrRes(18, rowRes) = Join(arrT, ";") 'place the string in column R:R
For m = rowRes + 1 To rowRes + count
'place the code ("A:A" content) and "Variant" string:
arrRes(1, m) = arrRef(i, 1): arrRes(2, m) = "Variant"
Next m
For m = 0 To UBound(arr) 'place the values in the 14th column
arrRes(14, rowRes + m + 1) = arr(m)
sumV = sumV + arr(m) 'calculate the values Sum
Next m
arrRes(14, rowRes) = sumV 'place the Sum in the 14th array column
If sumV > 0 Then arrRes(11, rowRes) = True Else: arrRes(11, rowRes) = False 'True/False
End If
rowRes = rowRes + count + 1: count = 0: sumV = 0 'reinitialize the necessary variables
Next i
ReDim Preserve arrRes(1 To 18, 1 To rowRes - 1) 'keep only the non empty array elements
wsRes.Range("A1").Resize(UBound(arrRes, 2), UBound(arrRes)).Value = Application.Transpose(arrRes)
MsgBox "Ready..."
End Sub
Please, test it and send some feedback.
Edited: lol you changed your question.. ;)
If you like make everything with "Select" then:
Sub Macro1()
Set ref = Workbooks("book1").Sheets("sheet1")
Set res = Workbooks("book2").Sheets("sheet2")
ref.Rows("6:6").Copy
res.Activate
res.Rows("9:9").Select
ActiveSheet.Paste
End Sub
But you should avoid using select if you will have a lot of data, as its perfomance is slow as hell.
I'm trying to make a macro that increases the time between data points as part of automatic data processing, but it currently takes way too long.
One of my sensors logs a data point every 10 seconds, I want to increase this dt to 1 hour. For this I wrote some very simple (inefficient) code (see below) that does work but takes 10-40 minutes to process 1 week of data which is far from ideal.
I've seen recommendations for semi-similar issues to use an array, however I have 0 experience with this and don't know if it's applicable to this goal.
Do While Cells(row + 1, 2).Value <> ""
If Cells(row + 1, 2).Value - Cells(row, 2).Value < 1 / 24.05 Then
Rows(row + 1).Select
Selection.Delete Shift:=xlUp
Else
row = row + 1
End If
Loop
EDIT:
I solved my issue with a slightly edited version of #Damian's code as shown below.
Sub Change_dt()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim target As Single
target = Sheets("Controller").Cells(16, 9).Value
Dim arrSource As Variant
With ThisWorkbook.Sheets("Raw data")
arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array
Dim finalArr As Variant
ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))
.Cells.Delete 'will clean the worksheet
Dim i As Long, x As Long, j As Long, Z As Long
x = 1
Z = 1
For i = 1 To UBound(arrSource)
On Error Resume Next
If arrSource(i + Z, 1) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end the loop once the next row is empty
On Error GoTo 0
'If the next row substracted the first is greater than target both will be copied to the final array
If arrSource(i + Z, 1) - arrSource(i, 1) > target Then
For j = 1 To UBound(arrSource, 2)
finalArr(x, j) = arrSource(i, j)
finalArr(x + 1, j) = arrSource(i + Z, j)
Next j
x = x + 2 'increment 2 on x because you wrote 2 lines
i = i + Z
Z = 1
Else
Z = Z + 1
End If
Next i
'paste the resulting array back to the sheet
.Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr
'eliminate the extra unused rows
i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Rows(i & ":" & .Rows.Count).Delete
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This should help a lot in your executing time:
Sub Change_dt()
Dim target As Single
target = Sheets("Controller").Cells(16, 9).Value
Dim arrSource As Variant
With ThisWorkbook.Sheets("Raw data")
arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array
Dim finalArr As Variant
ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))
.Cells.Delete 'will clean the worksheet
Dim i As Long, x As Long, j As Long
x = 1
For i = 5 To UBound(arrSource)
On Error Resume Next
If arrSource(i + 1, 2) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end the loop once the next row is empty
On Error GoTo 0
'If the next row substracted the first is greater than 1/24.05 both will be copied to the final array
If Not arrSource(i + 1, 2) - arrSource(i, 2) < target Then
For j = 1 To UBound(arrSource, 2)
finalArr(x, j) = arrSource(i, j)
finalArr(x + 1, j) = arrSource(i + 1, j)
Next j
x = x + 2 'increment 2 on x because you wrote 2 lines
End If
Next i
'paste the resulting array back to the sheet
.Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr
'eliminate the extra unused rows
i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Rows(i & ":" & .Rows.Count).Delete
End With
End Sub
In My office five Employee is working for example In my office Employ Entry Exit sheet is dere..
This is Main Sheet
Now my requirement
category wise data copy to this sheet to other sheet but it's do it automatically
Like Example
enter image description here
I hope I am interpreting your question correctly, but please let me know if I have misinterpreted your request.
Try the following code on your sheet:
Sub AutoCopyByName()
Dim Names() As String
Dim i As Long, NumRows As Long, NameRow() As Long
Dim j As Integer, NumNames As Integer
j = 0
NumSites = 0
'''''''''''''''''''''''''''''''''''''''''''
'''COUNT NUMBER OF ROWS WITH INFORMATION'''
'''''''''''''''''''''''''''''''''''''''''''
i = 2 'Standard Counter (counts all non-blank cells)
NumRows = 1 'Number of rows with information
Do While WorksheetFunction.IsText(Sheets("data").Range("A" & i))
If Sheets("data").Range("A" & i) <> " " Then NumRows = NumRows + 1
i = i + 1
Loop
'''''''''''''''''''''''''''
'''COUNT NUMBER OF NAMES'''
'''''''''''''''''''''''''''
For i = 3 To NumRows + 1
If Sheets("data").Cells(i, 1) <> Sheets("data").Cells(i - 1, 1) Then NumNames = NumNames + 1 'Works
Next i
''''''''''''''''''
'''REDIM ARRAYS'''
''''''''''''''''''
ReDim Names(NumNames)
ReDim NameRow(NumNames)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''FINDING THE LOCATION OF EACH NAME IN THE SHEET AND STORING IT IN NameRow ARRAY'''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 2 To NumRows + 1
If Sheets("data").Cells(i, 1) <> Sheets("data").Cells(i - 1, 1) Then
Names(j) = Sheets("data").Cells(i, 1).Value
NameRow(j) = i
j = j + 1
End If
Next i
'''''''''''''''''''''''''''''''''''''''''
'''COPY ENTRIES PER NAME TO EACH SHEET'''
'''''''''''''''''''''''''''''''''''''''''
For i = 0 To NumNames - 1
Worksheets.Add
Worksheets(1).Name = Names(i)
Worksheets("data").Rows(1).Copy
Worksheets(Names(i)).Paste
Worksheets("data").Activate
Worksheets("data").Range(Cells(NameRow(i), 1), Cells(NameRow(i + 1) - 1, 1)).EntireRow.Copy
Worksheets(Names(i)).Activate
Worksheets(Names(i)).Range("A2").Select
Worksheets(Names(i)).Paste
Next i
End Sub
I've used the following as my input sheet
I have created a nested for loop to compare 3 different cell values within 2 sheets. The loop works fine when the data is small, but when I run on 5,000 rows its too slow and crashes excel. Any idea of how to run this more efficiently.
Sub RowMatch()
Dim x As Integer
' Make sure we are in the right sheet
Worksheets("Q416").Activate
' Set numrows = number of rows of data.
NumRows = Range("C2", Range("C2").End(xlDown)).Rows.count
' find the reference range
Worksheets("Q415").Activate
NumRows2 = Range("C5", Range("C5").End(xlDown)).Rows.count
Worksheets("Q416").Activate
MsgBox ("Total # of Rows on this sheet = " & NumRows & " and " & NumRows2 & " in Ref Range")
Range("A1").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
'MsgBox NumRows2
For y = 1 To NumRows2
'MsgBox (ActiveCell.Offset(x, 0).Value & " & " & Worksheets("Q415").Cells(y + 1, 1))
If ActiveCell.Offset(x, 0).Value = Worksheets("Q415").Cells(y + 1, 1).Value _
And ActiveCell.Offset(x, 2).Value = Worksheets("Q415").Cells(y + 1, 3).Value Then
If ActiveCell.Offset(x, 5).Value = Worksheets("Q415").Cells(y + 1, 6).Value Then
'If NumRows(i).Value = ActiveCell.Offset(1, 0).Value Then
ActiveCell.Offset(x, 10).Value = "Same"
Else
ActiveCell.Offset(x, 10).Value = ActiveCell.Offset(x, 5).Value - Worksheets("Q415").Cells(y + 1, 6).Value
End If
End If
Next y
Next x
End Sub
Reading and writing to cells is one of the slowest operations you can do in Excel VBA. Instead, you should place the values contained in the worksheets into arrays and work with them there, Here is an excellent reference: http://www.cpearson.com/excel/ArraysAndRanges.aspx. Use your NumRows variables and either a column letter or number to define the ranges that will consitute the arrays e.g:
myRange = Range("A1:C" & NumRows)
myArray = myRange.value
From the link to Chip Pearsons site:
Dim Arr() As Variant
Arr = Range("A1:B10")
Dim R As Long
Dim C As Long
For R = 1 To UBound(Arr, 1) ' First array dimension is rows.
For C = 1 To UBound(Arr, 2) ' Second array dimension is columns.
Debug.Print Arr(R, C)
Next C
Next R
first time poster, long time reader.
Apologies if this is hard to follow.
I have a spreadsheet which has a list of first names and last names. What I am wanting to do is take all of the first names which have the same last name and place them, evenly(ish) and separated by a comma, into the 3 reference columns in the same spreadsheet for example;
Example of Completed Sheet
I would like to do this in VBA because there are 200+ names and growing, and later the code will use this information to create and populate more workbooks.
So far, what I have works for all last names which have 3 or less first names (ie; one per column) but I cannot get it to work for last names where there are more than 3 first names.
My thought was to read all of the names into an array, split out the elements which have more than 3 names into another array, join these together separated by a comma, to then be transferred to the relevant column on the sheet.
However for some reason, I cannot get it to output more than one name into the column.
I have had a few attempts at this, but this is my latest attempt;
Private Sub cmdUpdate_Click()
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
Dim namesPerCol As Long
Dim strLastNameMatches As String
Dim arrNames() As String
Dim arrMultiNames(3) As String
Application.ScreenUpdating = False
With ActiveSheet
'Finds the last row with data in it
lngLastRow = .Cells(.Rows.count, "A").End(xlUp).Row
End With
'Sort the Columns
Columns("A:E").Sort key1:=Range("A1"), Header:=xlYes
'Loop through the LastNames
For i = 2 To lngLastRow
'Second loop through the LastNames
For j = 2 To lngLastRow
'If the last name matches
If Cells(i, 2).Value = Cells(j, 2).Value Then
'If the cell is empty then
If Range("C" & i).Value = "" Then
'Place the name in colA into colC
Range("C" & i).Value = Range("A" & j).Value
Else
'If the cell is not empty, then place a comma and space and then the value from colA
Range("C" & i).Value = Range("C" & i).Value & ", " & Range("A" & j).Value
End If
End If
Next j
Next i
For i = 2 To lngLastRow
strLastNameMatches = Range("C" & i).Value
arrNames = Split(strLastNameMatches, ", ")
If UBound(arrNames) > 2 Then
namesPerCol = UBound(arrNames) / 3
For l = 0 To 1
For k = LBound(arrNames) To namesPerCol
arrMultiNames(l) = arrNames(k) & ", "
Next k
Next l
For m = LBound(arrMultiNames) To UBound(arrMultiNames)
Select Case m
Case 0
Range("C" & i).Value = arrMultiNames(m)
Case 1
Range("D" & i).Value = arrMultiNames(m)
Case 2
Range("E" & i).Value = arrMultiNames(m)
End Select
Next m
Else
For j = LBound(arrNames) To UBound(arrNames)
Select Case j
Case 0
Range("C" & i).Value = arrNames(j)
Case 1
Range("D" & i).Value = arrNames(j)
Case 2
Range("I" & i).Value = arrNames(j)
End Select
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
Apologies for the poor quality coding, I will work on tiding it up once it is all working.
Any help I can get to get this code splitting out the names evenly across the three columns will be greatly appreciated
This task might be simpler if you could store your data into a more tree-like structure. There are many ways to do this; I've used the Collection object as it's easy to handle an unknown number of items. Basically, there are collections within a collection, ie one collection of first names for each last name.
The sample below uses very rudimentary distribution code (which is also hard-coded to a split of 3), but the point is that iterating through and down the tree is far simpler:
Dim lastList As Collection, firstList As Collection
Dim lastText As String, firstText As String
Dim data As Variant, last As Variant, first As Variant
Dim output() As Variant, dist(1 To 3) As Long
Dim str As String
Dim r As Long, c As Long, i As Long
'Read data into an array
With Sheet1
data = .Range(.Range("A1"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
'Create lists of unique lastnames containing the firstnames
Set lastList = New Collection
For r = 2 To UBound(data, 1)
firstText = CStr(data(r, 1))
lastText = CStr(data(r, 2))
Set firstList = Nothing
On Error Resume Next
Set firstList = lastList(lastText)
On Error GoTo 0
If firstList Is Nothing Then
Set firstList = New Collection
lastList.Add firstList, lastText
End If
firstList.Add firstText
Next
'Write results to sheet
ReDim output(1 To UBound(data, 1) - 1, 1 To 3)
For r = 2 To UBound(data, 1)
lastText = CStr(data(r, 2))
Set firstList = lastList(lastText)
'Calculate the distribution
dist(3) = firstList.Count / 3 'thanks #Comitern
dist(2) = dist(3)
dist(1) = firstList.Count - dist(2) - dist(3)
i = 1: c = 1: str = ""
For Each first In firstList
str = str & IIf(i > 1, ", ", "") & first
i = i + 1
If i > dist(c) Then
output(r - 1, c) = str
i = 1: c = c + 1: str = ""
End If
Next
Next
Sheet1.Range("C2").Resize(UBound(output, 1), UBound(output, 2)).Value = output