I have hit a roadblock trying to think through how I might write the VBA code that counts the number of unique order numbers and and whether the order status is open or closed for each salesperson.
I am working on writing the VBA that would affect Sheet2. I need the VBA to loop through Sheets("Sheet2").Range("A:A") and (1) lookup the name in Sheet1; (2a) count the unique order numbers that correspond with the salesperson's name and are "Open" and (2b) count the unique order numbers that correspond with the salesperson's name and are "Closed". I have designed "?"s for the values I am looking to calculate with the macro and included the answer numbers.
Any help is greatly appreciated. Please let me know if I can clarify anything.
Sheet1 - Orders
Sheet2 - Orders Summary
A B C
1 **Name** **Count-Uniq Open Orders** **Count-Uniq Closed Orders**
2 John ? (answer: 2) ? (answer: 0)
3 Ben ? (answer: 1) ? (answer: 1)
4 Fred ? (answer: 1) ? (answer: 0)
Tested:
Sub Tester()
Dim d1, d2, arrIn, r, tmp, nm, id, i
Dim c, k
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With Sheets("orders")
arrIn = .Range(.Range("A2"), _
Cells(Rows.Count, 3).End(xlUp)).Value
End With
For r = 1 To UBound(arrIn, 1)
nm = arrIn(r, 1) 'name
id = arrIn(r, 2) 'order #
If Not d1.exists(nm) Then
d1.Add nm, Array(0, 0)
End If
If Not d2.exists(id) Then
tmp = d1(nm)
i = IIf(UCase(arrIn(r, 3)) = "OPEN", 0, 1)
tmp(i) = tmp(i) + 1
d1(nm) = tmp
d2.Add id, 0
End If
Next r
Set c = Sheets("summary").Range("a2")
For Each k In d1.keys
c.Resize(1, 3).Value = Array(k, d1(k)(0), d1(k)(1))
Set c = c.Offset(1, 0)
Next k
End Sub
Try this one :)
Sub Macro1()
Dim ws1 As Worksheet, ws2 As Worksheet, wsTemp As Worksheet
Dim rng As Range
Dim myformula1 As String, myformula2 As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set ws1 = ThisWorkbook.Sheets("Sheet1") 'where you have your Orders
Set ws2 = ThisWorkbook.Sheets("Sheet2") 'where you have your summary which should have names in it
ws1.Copy ThisWorkbook.Sheets(1)
Set wsTemp = ActiveSheet: wsTemp.Name = "Temp"
With wsTemp
Set rng = .UsedRange
rng.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End With
myformula1 = "=COUNTIFS(" & wsTemp.Name & "!A:A,A2," & wsTemp.Name & "!C:C,""Open"")"
myformula2 = "=COUNTIFS(" & wsTemp.Name & "!A:A,A2," & wsTemp.Name & "!C:C,""Closed"")"
With ws2.Range(ws2.Range("A2"), ws2.Range("A" & ws2.Rows.Count).End(xlUp))
.Offset(0, 1).Formula = myformula1
.Offset(0, 2).Formula = myformula2
.Offset(0, 1).Resize(, 2).Value = .Offset(0, 1).Resize(, 2).Value
End With
wsTemp.Delete
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
No loop. Just to give you an alternative :D
Hope this helps in any way.
In cell B2 of sheet 2:
=SUM(IF(FREQUENCY(IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=B$1,Sheet1!$B$2:$B$10)),IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=B$1,Sheet1!$B$2:$B$10)))>0,1))
This is an array formula so to confirmit hold Ctrl + Shift and hit Enter, this will add a { and } at start and end respectively.
In cell C3:
=SUM(IF(FREQUENCY(IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=C$1,Sheet1!$B$2:$B$10)),IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=C$1,Sheet1!$B$2:$B$10)))>0,1))
Same again, it's an array so Ctrl+Shift and Enter
And then copy the formulae down.
Just as an alternative, in terms of a pivot table solution the following answer covers the techniques required:
Simple Pivot Table to Count Unique Values
Related
I am trying to build a excel vba code that looks at data from three columns, takes the lowest 6 values of each variable (which there are four of) and also takes the adjacent column and pastes it in another sheet.
This is the input:
This is what I would like the output to be:
!
This is what the output actually is:
Actual Output
I stole a lot of this code from another post I saw, but it seems to be acting very randomly. I'm still not quite sure what the code is even doing, which is what makes it hard for me.
Any advice will help tremendously.
UPDATE: Using Ibo's fix on my sample data, it worked perfectly, however on my actual data it errored out. The reason I am doing this through a macro instead of manually is because it is a part of a much larger macro that is getting pieced together to predict production consumption of various raw materials and what needs to get staged.
Here's what happened:
Actual Input Data
Error 1004 Message and highlighted code
Output after failure
It looks like it got close, but didn't finish with the actual sort.
Sub TopPriorityPerPod()
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rngData As Range
Dim rngFound As Range
Dim rngUnqGroups As Range
Dim GroupCell As Range
Dim lCalc As XlCalculation
Dim aResults() As Variant
Dim aOriginal As Variant
Dim lNumTopEntries As Long
Dim i As Long, j As Long, k As Long
'Change to grab the top X number of entries per category'
lNumTopEntries = 6
Set wsData = ActiveWorkbook.Sheets("copy") 'This is where your data is'
Set wsDest = ActiveWorkbook.Sheets("Sheet6") 'This is where you want to output it'
Set rngData = wsData.Range("A2", wsData.Cells(Rows.Count, "C").End(xlUp))
aOriginal = rngData.Value 'Store original values so you can set them back later'
'Turn off calculation, events, and screenupdating'
'This allows code to run faster and prevents "screen flickering"'
With Application
lCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
'If there are any problems with the code, make sure the calculation, events, and screenupdating get turned back on'
'On Error GoTo CleanExit
With rngData
'.Sort .Resize(, 1).Offset(, 1), xlAscending, .Resize(, 1).Offset(, 2), , xlDescending, Header:=xlYes
.Sort .Resize(, 1).Offset(, 1), xlDescending, Header:=xlYes
End With
With rngData.Resize(, 1).Offset(, 1)
.AdvancedFilter xlFilterInPlace, , , True
Set rngUnqGroups = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.Parent.ShowAllData 'Remove the filter
ReDim aResults(1 To rngUnqGroups.Cells.Count * lNumTopEntries, 1 To 4)
i = 0
For Each GroupCell In rngUnqGroups
Set rngFound = .Find(GroupCell.Value, .Cells(.Cells.Count))
k = 0
If Not rngFound Is Nothing Then
For j = i + 1 To i + lNumTopEntries
If rngFound.Offset(j - i - 1).Value = GroupCell.Value Then
k = k + 1
aResults(j, 1) = rngFound.Offset(j - i - 1, -1).Value
aResults(j, 2) = rngFound.Offset(j - i - 1).Value
aResults(j, 3) = rngFound.Offset(j - i - 1, 1).Value
aResults(j, 4) = rngFound.Offset(j - i - 1, 2).Value
End If
Next j
i = i + k
End If
Next GroupCell
End With
'Output results'
wsDest.Range("A2").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
CleanExit:
'Turn calculation, events, and screenupdating back on'
With Application
.Calculation = lCalc
.EnableEvents = True
.ScreenUpdating = True
End With
If Err.Number <> 0 Then
'There was an error, show the error'
MsgBox Err.Description, , "Error: " & Err.Number
Err.Clear
End If
'Put data back the way it was
rngData.Value = aOriginal
End Sub
You can have different approaches. In this method I copy the data to another sheet called Result, then insert a table, sort the columns and then collect the range where the rows are more than 6 and then delete the whole rows at once, it will be really fast:
Sub Main()
Dim i As Long
Dim rng As Range
Dim tbl As ListObject
Dim WS As Worksheet
Dim WS2 As Worksheet
Set WS = Worksheets("Sheet1") 'this is where you have the data
Set WS2 = Worksheets.Add
WS2.Name = "Result"
WS.Range("A1").CurrentRegion.Copy
WS2.Paste
'sort priority column first
WS2.ListObjects.Add(xlSrcRange, Range(WS2.UsedRange.Address), , xlYes).Name = "Table1"
Set tbl = WS2.ListObjects("Table1")
tbl.Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Priority]]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'sort station column
tbl.Sort.SortFields.Clear
tbl.Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Station]]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'remove any row exceeding 6th occurrence
Dim cnt As Integer
For i = 1 To tbl.ListRows.Count - 1
If tbl.ListColumns("Station").DataBodyRange(i, 1).Value = tbl.ListColumns("Station").DataBodyRange(i + 1, 1).Value Then
cnt = cnt + 1
If cnt >= 6 Then
If rng Is Nothing Then
Set rng = tbl.ListColumns("Station").DataBodyRange(i + 1, 1)
Else
Set rng = Application.Union(rng, tbl.ListColumns("Station").DataBodyRange(i + 1, 1))
End If
End If
Else
cnt = 0 'reset the counter
End If
Next i
'remove rows
If Not rng Is Nothing Then
tbl.Unlist
rng.EntireRow.Delete
End If
End Sub
So I've put something together for you that should get you most of the way there.
You'll need to do a few things to get this working for your file (learning opportunity!):
(1) Adjust the ranges as relevant to your file
(2) Print the output to the worksheet. As of right now the output is being printed to the immediate debug window.
What this code will do is sort out each letters values into a collection named after the letters.
From there we convert the collection to an array. We then utilize the "Small" worksheet function on the arrays, and loop through the 6 lowest values.
Happy to help with any further questions you may have!
Public Function CollectionToArray(myCol As Collection) As Variant
'Thanks to user Vityata for this converter function (https://stackoverflow.com/users/5448626/vityata).
Dim result As Variant
Dim cnt As Long
ReDim result(myCol.Count - 1)
For cnt = 0 To myCol.Count - 1
result(cnt) = myCol(cnt + 1)
Next cnt
CollectionToArray = result
End Function
Sub ArraySort()
Dim Cell As Range
Dim KeyMultiple As String
Dim collA As New Collection
Dim collB As New Collection
Dim collC As New Collection
Dim collD As New Collection
Dim Rng_Col As Range
Set Rng_Col = Sheets("Sheet1").Range("A2:A22")
Dim GroupByArr As Variant
GroupByArr = Array("A", "B", "C")
Counter = 0
For i = 1 To 22
If Cells(i, 1).Value = "A" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collA.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "B" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collB.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "C" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collC.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "D" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collD.Add Item:=Cells(i, 2), Key:=KeyMultiple
End If
Next i
For i = 1 To 6
Debug.Print WorksheetFunction.Small(CollectionToArray(collA), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collB), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collC), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collD), i)
Next i
Set collA = New Collection
Set collB = New Collection
Set collC = New Collection
Set collD = New Collection
End Sub
here's a solution exploiting Array, Dictionary and SortedList object, that shuold be quite fast:
Option Explicit
Sub main()
Dim wsData As Worksheet: Set wsData = ActiveWorkbook.Sheets("copy") 'This is where your data is'
Dim wsDest As Worksheet: Set wsDest = ActiveWorkbook.Sheets("Sheet6") 'This is where you want to output
Dim stations As Variant, station As Variant
Dim iStation As Long
Dim stationsList As Object: Set stationsList = CreateObject("Scripting.Dictionary") ' use dictionary to collect unique station values
With wsData
stations = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 3).Value
For iStation = 1 To UBound(stations, 1)
stationsList(stations(iStation, 1)) = stationsList(stations(iStation, 1)) & stations(iStation, 2) & "|" & stations(iStation, 3) & " " ' update current station priorities list and orders
Next
End With
Dim prioritiesAndOrders As Variant, priorityAndOrder As Variant, priority As Variant, order As Variant
Dim iPriority As Long, nPriorities As Long
For Each station In stationsList.Keys ' loop through unique stations
prioritiesAndOrders = Split(Trim(stationsList(station)), " ") ' get current station priorities and corresponding orders list
With CreateObject("System.Collections.SortedList") ' cerate and reference a sortedList object (it stores keys in ascending order)
For Each priorityAndOrder In prioritiesAndOrders ' loop through current station priorities and corresponding orders list
priority = Split(priorityAndOrder, "|")(0) ' get current priority
order = Split(priorityAndOrder, "|")(1) 'get current priority corresponding order
.Add priority, order ' store current priority as "key" of SortedList object and its corresponding order as its value
Next
nPriorities = WorksheetFunction.Min(.Count - 1, 5) ' define the current station number of priorities to manage
ReDim results(1 To nPriorities + 1, 1 To 3) As Variant ' size results array accordingly
For iPriority = 0 To nPriorities ' loop through current station sorted priorities (and corresponding orders) and fill results array with current station in column 1, its priorities in column 2 and priority corresponding order in column 3
results(iPriority + 1, 1) = station
results(iPriority + 1, 2) = .GetKey(iPriority)
results(iPriority + 1, 3) = .GetValueList()(iPriority)
Next
End With
wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Offset(1).Resize(nPriorities + 1, 3).Value = results ' write current station sorted priorities
Next
End Sub
I need to create a sub to consolidate some data. I have several rows (anywhere from 4k to 20k) that I need to consolidate and sum the values from each column (from C to N).
The input data looks like this:
input
For the output, it should sum the columns for each SKU (Column A) and delete the rest.
Like this:
output
It should be simple enough, but I can’t seem to come up with an appropriate solution. I tried using an array with a scripting dictionary but I can’t figure out how to store more than a single value for each key. Sample (unfinished) code:
Dim sArray As Variant
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
sArray = Range(currentRange).Value
For i = 1 To UBound(sArray, 1)
For j = 3 To UBound(sArray, 2)
If dict.exists(sArray(i, 1)) = False Then
dict.Add sArray(i, 1), sArray(i, j)
Else
'this part is very wrong:
dict(sArray(i, 1)) = dict(sArray(i, j)) + sArray(i, j)
End If
Next
Next
Thank you very much in advance!
Try this, It sums the values in Column Q:AB then paste them back and removes the duplicates.
Sub dupremove()
Dim ws As Worksheet
Dim lastrow As Long
Set ws = Sheets("Sheet12") ' Change to your sheet
With ws
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C2:N" & lastrow)
.Offset(, 14).FormulaR1C1 = "=SUMIF(C1,RC1,C[-14])"
.Value = .Offset(, 14).Value
.Offset(, 14).ClearContents
End With
With .Range("A1:N" & lastrow)
.Value = .Value
.RemoveDuplicates 1, xlYes
End With
End With
Before:
After:
I came up with the following solution instead and it took 30 seconds to run it (not entirely my own idea, borrowed some code from someplace else):
Sub dupes()
Dim MyRange As Range
Dim RowNum As Long
RowNum = 1
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set MyRange = Range("A2:N14200") 'for test only, on the real sub it's dynamic
MyRange.Sort key1:=Range("A2"), order1:=xlAscending
For Each Row In MyRange
With Cells
While Cells(RowNum, 1) = Cells(RowNum + 1, 1) And Cells(RowNum + 1, 1) <> "" 'very important the second condition or it will continue to loop forever
For i = 3 To 14
Cells(RowNum, i) = Cells(RowNum, i) + Cells(RowNum + 1, i)
Next
Rows(RowNum + 1).EntireRow.Delete
Wend
End With
RowNum = RowNum + 1
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
It's kinda messy but it does the trick. Thanks to everyone!
I have done the following 2 VBA code in excel. Main purpose is to combine multiple address rows into a single line. Problem is it takes forever to run. Is there anyway I can optimise it?
The data is as such, there is a case# for each of the customer address. The customer address can be split into multiple rows. Example: "Address row 1 - Block 56", "Address row 2 - Parry Avenue", "address row 3 - Postal code". There is a blank space between each new address.
My purpose is to combine the address into a single line, and remove the empty rows in between the case numbers eg "Block 56 Parry Avenue Postal code". There are approx 26K case numbers.
Sub test()
Dim l As Long
Dim lEnd As Long
Dim wks As Worksheet
Dim temp As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wks = Sheets("data")
wks.Activate
lEnd = ActiveSheet.UsedRange.Rows.Count
For l = 3 To lEnd
If Not IsEmpty(Cells(l, 1)) Then
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
Else: Cells(l, 1).EntireRow.Delete
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
End If
Next l
End Sub
and the 2nd code I tried
Sub transformdata()
'
Dim temp As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("A3").Select
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
Do Until IsEmpty(ActiveCell.Offset(1, 3))
temp = ActiveCell.Offset(, 3).Value & " " & ActiveCell.Offset(1, 3).Value
ActiveCell.Offset(, 3).Value = temp
ActiveCell.Offset(1, 3).EntireRow.Delete
Loop
ActiveCell.Offset(1, 0).EntireRow.Delete
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Change the line lEnd = ActiveSheet.UsedRange.Rows.Count. Incorrect way of finding last row. You may want to see This
To delete rows where Cells(l, 1) is empty, use Autofilter. See This
Do not delete rows in a straight loop. Use a reverse loop. Or what you could do is identify the cells that you want to delete in a loop and then delete them in one go after the loop. You may want to see This
Here is a basic example.
Let's say your worksheet looks like this
If you run this code
Sub test()
Dim wks As Worksheet
Dim lRow As Long, i As Long
Dim temp As String
Application.ScreenUpdating = False
Set wks = Sheets("data")
With wks
'~~> Find Last Row
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
For i = lRow To 2 Step -1
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
If temp = "" Then
temp = .Range("C" & i).Value
Else
temp = .Range("C" & i).Value & "," & temp
End If
Else
.Range("D" & i + 1).Value = temp
temp = ""
End If
Next i
End With
End Sub
You will get this output
Now simply run the autofilter to delete the rows where Col D is empty :) I have already give you the link above for the same.
The code below will copy all the data into an array, consolidate it, and add it to a new worksheet. You'll need to make COLUMNCOUNT = the number of columns that contain data.
Sub TransformData2()
Const COLUMNCOUNT = 4
Dim SourceData, NewData
Dim count As Long, x1 As Long, x2 As Long, y As Long
SourceData = Range("A" & Range("D" & Rows.count).End(xlUp).Row, Cells(3, COLUMNCOUNT))
For x1 = 1 To UBound(SourceData, 1)
count = count + 1
If count = 1 Then
ReDim NewData(1 To 4, 1 To count)
Else
ReDim Preserve NewData(1 To 4, 1 To count)
End If
For y = 1 To UBound(SourceData, 2)
NewData(y, count) = SourceData(x1, y)
Next
x2 = x1 + 1
Do
NewData(4, count) = NewData(4, count) & " " & SourceData(x2, 4)
x2 = x2 + 1
If x2 > UBound(SourceData, 1) Then Exit Do
Loop Until IsEmpty(SourceData(x2, 4))
x1 = x2
Next
ThisWorkbook.Worksheets.Add
Range("A1").Resize(UBound(NewData, 2), UBound(NewData, 1)).Value = WorksheetFunction.Transpose(NewData)
End Sub
I have a problem with a specific excel task. Although I searched the web thoroughly for tips and parts of code I could use, I was not able to get near a functioning solution.
This is my problem:
I have around 30 Worksheets with two columns each.
The number of Rows varies from WS to WS but the two columns on each sheet are equally long.
The first column of each Sheet contains minimum values and the second column holds the respective maximum values.
E.g.
| A | B
1 | 1000 | 1010
2 | 2020 | 2025
Now I need one single column with all values from these intervals including the Max and Min values.
Preferred solution in Column C:
1000, 1001, 1002, 1003, 1004, 1005, 1006, 1007, 1008, 1009, 1010, 2020, 2021, 2022, 2023, 2024, 2025
I thought of highlighting the two columns and then activating a macro to generate the list. I would then repeat this process for each WS manually. Some sheets have only 4 to 20 rows but some have over 7000 rows.
And if it helps anything: The numbers are postcodes ;-)
I'd be very grateful for any kind of help.
Thanks in advance!
Try this:
Sub Test()
Dim LastRow As Long, ColIndex As Long
Dim i As Long, j As Long
Dim min As Long, max As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
ColIndex = 1
For i = 1 To LastRow
min = ws.Cells(i, 1).Value
max = ws.Cells(i, 2).Value
For j = min To max
ws.Cells(ColIndex, 3).Value = j
ColIndex = ColIndex + 1
Next j
Next i
Next ws
End Sub
edited: to have one big string in column "C" (added two lines in each code)
edited 2: added "zip3" solution for having all values listed in "C" column only
you could use either following ways
Option Explicit
Sub zips3()
'list values in column "C" in sequence from all min to max in columns "A" and "B"
Dim sht As Worksheet
Dim cell As Range
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
With cell.End(xlToRight).Offset(, 2).Resize(, cell.Offset(, 1).Value - cell.Value + 1)
.FormulaR1C1 = "=RC1+COLUMN()-4"
sht.Range("C" & sht.Cells(sht.Rows.Count, "C").End(xlUp).Row).Offset(1).Resize(.Columns.Count) = Application.Transpose(.Value)
.ClearContents
End With
Next cell
If IsEmpty(sht.Range("C1")) Then sht.Range("C1").Delete (xlShiftUp)
Next sht
End Sub
Sub zips()
'list values in column "C" from corresponding min to max in columns "A" and "B"
Dim sht As Worksheet
Dim cell As Range
Dim j As Long
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
For j = cell.Value To cell.Offset(, 1).Value
cell.End(xlToRight).Offset(, 1) = j
Next j
'lines added to have one bg string in column "C"
cell.Offset(, 2).Value2 = "'" & Join(Application.Transpose(Application.Transpose(Range(cell.Offset(, 2), cell.Offset(, 2).End(xlToRight)))), ",")
Range(cell.Offset(, 3), cell.Offset(, 3).End(xlToRight)).ClearContents
Next cell
Next sht
End Sub
Sub zips2()
Dim sht As Worksheet
Dim cell As Range
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
cell.End(xlToRight).Offset(, 1).Resize(, cell.Offset(, 1).Value - cell.Value + 1).FormulaR1C1 = "=RC1+COLUMN()-3"
'lines added to have one bg string in column "C"
cell.Offset(, 2).Value2 = "'" & Join(Application.Transpose(Application.Transpose(Range(cell.Offset(, 2), cell.Offset(, 2).End(xlToRight)))), ",")
Range(cell.Offset(, 3), cell.Offset(, 3).End(xlToRight)).ClearContents
Next cell
Next sht
End Sub
A solution you can use as you like would be kinda like this:
Public Function getZIPs(rng As Range) As String
Dim myVal As Variant, str As String, i As Long, j As Long
myVal = Intersect(rng, rng.Parent.UsedRange).Value
For i = 1 To UBound(myVal)
If IsNumeric(myVal(i, 1)) And IsNumeric(myVal(i, 2)) And Len(myVal(i, 1)) > 0 And Len(myVal(i, 2)) > 0 Then
If myVal(i, 1) <= myVal(i, 2) Then
For j = myVal(i, 1) To myVal(i, 2)
str = str & ", " & j
Next
End If
End If
Next
getZIPs = Mid(str, 3)
End Function
Put this into a module and then either go for C1: =getZIPs(A1:B1) and auto fill down or directly =getZIPs(A:B) to get all numbers in one cell or use it in a sub to do it automatically.
If you have any questions, just ask :)
EDIT:
If you want it all exactly in the one-column-way, you can use this (should be fast):
Sub getMyList()
Dim sCell As Range, gCell As Range
Set gCell = ActiveSheet.[A1:B1]
Set sCell = ActiveSheet.[C1]
Dim sList As Variant
While IsNumeric(gCell(1)) And IsNumeric(gCell(2)) And Len(gCell(1)) > 0 And Len(gCell(2)) > 0
If gCell(1) = gCell(2) Then
sCell.Value = gCell(1)
Set sCell = sCell.Offset(1)
Else
sList = Evaluate("ROW(" & gCell(1) & ":" & gCell(2) & ")")
sCell.Resize(UBound(sList)).Value = sList
Set sCell = sCell.Offset(UBound(sList))
End If
Set gCell = gCell.Offset(1)
Wend
End Sub
If you have any questions, just ask ;)
I have two columns of numbers, together they will be unique (composite key). I would like to create an unique ID number (third column) similar to how MS Access would use a primary key. I would like to do this in VBA but I am stuck on how to do it.
My VBA in excel isn't very good so hopefully you can see what I've started to attempt. it may be completely wrong... I don't know?
I don't know how to make the next concatenation and I am unsure about how to go down to the next row correctly.
Sub test2()
Dim var As Integer
Dim concat As String
concat = Range("E2").Value & Range("F2").Value
var = 1
'make d2 activecell
Range("D2").Select
Do Until concat = ""
'if the concat is the same as the row before we give it the same number
If concat = concat Then
var = var
Else
var = var + 1
End If
ActiveCell.Value = var
ActiveCell.Offset(0, 1).Select
'make the new concatination of the next row?
Loop
End Sub
any help is appreciated, thanks.
Give the code below a try, I've added a loop which executes for each cell in the E Column. It checks if the concat value is the same as the concat value in the row above and then writes the id to the D cell.
Sub Test2()
Dim Part1 As Range
Dim strConcat As String
Dim i As Long
i = 1
With ThisWorkbook.Worksheets("NAME OF YOUR SHEET")
For Each Part1 In .Range(.Cells(2, 5), .Cells(2, 5).End(xlDown))
strConcat = Part1 & Part1.Offset(0, 1)
If strConcat = Part1.Offset(-1, 0) & Part1.Offset(-1, 1) Then
Part1.Offset(0, -1).Value = i
Else
i = i + 1
Part1.Offset(0, -1).Value = i
End If
Next Part1
End With
End Sub
Something like this should work, this will return a Unique GUID (Globally Unique Identifier):
Option Explicit
Sub Test()
Range("F2").Select
Do Until IsEmpty(ActiveCell)
If (ActiveCell.Value <> "") Then
ActiveCell.Offset(0, 1).Value = CreateGUID
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Public Function CreateGUID() As String
CreateGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function
If you walk down column D and examine the concatenated values from column E and F with the previous row, you should be able to accomplish your 'primary key'.
Sub priKey()
Dim dcell As Range
With Worksheets("Sheet12")
For Each dcell In .Range(.Cells(2, 4), .Cells(Rows.Count, 5).End(xlUp).Offset(0, -1))
If LCase(Join(Array(dcell.Offset(0, 1).Value2, dcell.Offset(0, 2).Value2), ChrW(8203))) = _
LCase(Join(Array(dcell.Offset(-1, 1).Value2, dcell.Offset(-1, 2).Value2), ChrW(8203))) Then
dcell = dcell.Offset(-1, 0)
Else
dcell = Application.Max(.Range(.Cells(1, 4), dcell.Offset(-1, 0))) + 1
End If
Next dcell
End With
End Sub
You could use collections as well.
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range, LstRw As Long
Dim Cell As Range
Dim vNum As Variant, c As Range, y
LstRw = Cells(Rows.Count, "E").End(xlUp).Row
Set Rng = Range("E2:E" & LstRw)
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value & Cell.Offset(, 1), CStr(Cell.Value & Cell.Offset(, 1))
Next Cell
On Error GoTo 0
y = 1
For Each vNum In cUnique
For Each c In Rng.Cells
If c & c.Offset(, 1) = vNum Then
c.Offset(, -1) = y
End If
Next c
y = y + 1
Next vNum
End Sub