I originally had an Excel spreadsheet which was used to record values of JOB LOT IDs (>10000). I used the following array formula -
=INDIRECT(TEXT(MIN(IF(($C$3:$S$52<>"")*(COUNTIF($V$3:V3,$C$3:$S$52)=0),ROW($3:$52)*100+COLUMN($C$S),7^8)),"R0C00"),)&""
Data:
| pallet | Lot# | Lot# | Lot# | Lot# | Lot# |
|-------- |------- |------- |-------- |------- |-------- |
| 1 | 12345 | 12346 | 12345 | 12347 | 123456 |
| 2 | 12345 | 12346 | 12348 | 12348 | 12343 |
| 3 | 12345 | 12347 | 123456 | 12348 | 12348 |
This worked fine if the cells in that range all represented the JOB LOT IDs.
It would record the unique LOT #'s as I copied this into the result range and coupled with the counting formula
(IF(LEN(V4)>0,COUNTIF($C$3:$S$52,V4),"")
in the adjacent cell. It returned:
Unique
Value Count
______ _____
12345 4
12346 2
12347 2
123456 2
12348 4
12343 1
Unfortunately, the scope of the job and spreadsheet changed such that the spreadsheet needed to include columns before each JOB LOT cell to record the Case# of the JOB LOT.
What I need help with is figuring out how to disregard the case# data, which will always be between 1 and 451, and only count the unique JOB LOT IDs, which will always be > 100000. Resulting in only the unique list of Job Numbers. Using the same array formula with the added column for Case#, the Case Numbers are also listed, when they are not needed or wanted.
| pallet | case# | Lot# | case# | Lot# | case# | Lot# | case# | Lot# | case# | Lot# |
|-------- |------- |------- |------- |------- |------- |-------- |------- |------- |------- |-------- |
| 1 | 1 | 12345 | 45 | 12346 | 356 | 12345 | 6 | 12347 | 7 | 123456 |
| 2 | 3 | 12345 | 35 | 12346 | 212 | 12348 | 23 | 12348 | 200 | 12343 |
| 3 | 54 | 12345 | 34 | 12347 | 450 | 123456 | 345 | 12348 | 367 | 12348 |
The result is
Unique
Value Count
______ _____
12345 4
45 1
12346 2
356 1
6 1
12347 2
7 1
123456 2
35 1
212 1
12348 4
23 1
200 1
12343 1
34 1
450 1
345 1
367 1
Any Suugestions?
Thanks.
You could use a dictionary to hold the unique Lot# as keys and add one to the value associated with this key each time the key is encountered again.
The data is read in from the sheet, from column C to the right most column, into an array, arr. arr is looped only looking at every other column i.e. the Lot# columns. The contents of the dictionary i.e. the unique Lot# (Keys) and count of them (Items), are written out to sheet2.
It assumes your data starts in A1 and has the layout given in the question.
Option Explicit
Public Sub GetUniqueValueByCounts()
Dim arr(), i As Long, j As Long, dict As Object, lastColumn As Long, lastRow As Long
Const NUMBER_COLUMNS_TO_SKIP = 2
Set dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
If lastColumn < 3 Or lastRow < 2 Then Exit Sub
arr = .Range(.Cells(2, 3), .Cells(lastRow, lastColumn)).Value
For i = LBound(arr, 2) To UBound(arr, 2) Step NUMBER_COLUMNS_TO_SKIP
For j = LBound(arr, 1) To UBound(arr, 1)
If arr(j, i) <> vbNullString Then
dict(arr(j, i)) = dict(arr(j, i)) + 1
End If
Next
Next
End With
With Worksheets("Sheet2")
.Range("A1").Resize(dict.Count, 1) = Application.WorksheetFunction.Transpose(dict.Keys)
.Range("B1").Resize(dict.Count, 1) = Application.WorksheetFunction.Transpose(dict.Items)
End With
End Sub
Ordered results:
You can use a sortedList to get ordered results though you lose the nice .Keys and .Items methods of generating arrays in one go to write to the sheet.
Option Explicit
Public Sub GetUniqueValueByCounts()
Dim arr(), i As Long, j As Long, dict As Object, lastColumn As Long, lastRow As Long, list As Object
Const NUMBER_COLUMNS_TO_SKIP = 2
Set dict = CreateObject("Scripting.Dictionary")
Set list = CreateObject("System.Collections.SortedList")
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
If lastColumn < 3 Or lastRow < 2 Then Exit Sub
arr = .Range(.Cells(2, 3), .Cells(lastRow, lastColumn)).Value
For i = LBound(arr, 2) To UBound(arr, 2) Step NUMBER_COLUMNS_TO_SKIP
For j = LBound(arr, 1) To UBound(arr, 1)
If arr(j, i) <> vbNullString Then
With list
If Not .contains(arr(j, i)) Then
list.Add arr(j, i), 1
Else
list(arr(j, i)) = list(arr(j, i)) + 1
End If
End With
End If
Next
Next i
End With
With Worksheets("Sheet2")
For j = 0 To list.Count - 1
.Cells(j + 1, 1) = list.GetKey(j)
.Cells(j + 1, 2) = list.GetByIndex(j)
Next
End With
End Sub
Related
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 7 months ago.
Improve this question
I am new to vba and I've got two updating columns of text & I want to find the union of the two columns.
For Example:
+---------+---------+
| A | B |
| 1 | 1 |
| 1 | 2 |
| 1 | 3 |
| 2 | 4 |
| 3 | 5 |
| 4 | 6 |
| 4 | 7 |
... so on
I want to write the result in a new column A, B, C ...
With column A
number 1, 1 to 3
number 2, 4 to 4 (if not duplicate at value column A)
number 3, 5 to 5
number 4, 6 to 7
like this :
+---------+---------+---------+
| A | B | C |
| 1 | 1 | 3 |
| 2 | 4 | 4 |
| 3 | 5 | 5 |
| 4 | 6 | 7 |
... so on
How to work out this? Thanks in advanced
Please, use the next code. It will return in columns E:F, starting with the second row.
Sub extractMinMax()
Dim sh As Worksheet, lastR As Long, arr, arrIt, arrFin, i As Long, j As Long, dict As New Scripting.Dictionary
Set sh = ActiveSheet 'use here the necessary sheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:B" & lastR).Value2
'place the range in a dictionay:
For i = 1 To UBound(arr)
If Not dict.Exists(arr(i, 1)) Then
dict.Add arr(i, 1), Array(arr(i, 2))
Else
arrIt = dict(arr(i, 1))
ReDim Preserve arrIt(UBound(arrIt) + 1)
arrIt(UBound(arrIt)) = arr(i, 2)
dict(arr(i, 1)) = arrIt
End If
Next i
'process the dictionary content
ReDim arrFin(1 To dict.count, 1 To 3)
For i = 0 To dict.count - 1
arrFin(i + 1, 1) = dict.Keys()(i)
arrFin(i + 1, 2) = WorksheetFunction.min(dict.Items()(i))
arrFin(i + 1, 3) = WorksheetFunction.Max(dict.Items()(i))
Next i
'drop the processed array content:
sh.Range("E2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin
End Sub
+-----+----------+----------+
| a | b | c |
+-----+----------+----------+
| 101 | 12:13:00 | employee |
| 102 | 12:15:00 | customer |
| 103 | 12:20:00 | employee |
| 102 | 12:16:00 | customer |
| 103 | 18:15:00 | employee |
| 101 | 18:18:00 | customer |
+-----+----------+----------+
how to separate rows to different sheets according to a column values automatically
finally get three sheets:
column a values 101
+-----+----------+----------+
| a | b | c |
+-----+----------+----------+
| 101 | 12:13:00 | employee |
| 101 | 18:18:00 | customer |
+-----+----------+----------+
column a values 102
+-----+----------+----------+
| a | b | c |
+-----+----------+----------+
| 102 | 12:15:00 | customer |
| 102 | 12:16:00 | customer |
+-----+----------+----------+
column a values 103
+-----+----------+----------+
| a | b | c |
+-----+----------+----------+
| 103 | 12:20:00 | employee |
| 103 | 18:15:00 | employee |
+-----+----------+----------+
try
Sub test()
Dim sht As Worksheet, r As Range
For Each r In ActiveSheet.UsedRange.Columns(1).Cells
On Error Resume Next
Set sht = Worksheets("_" & r.Value)
If sht Is Nothing Then
With Worksheets.Add
.Name = "_" & r.Value
With .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
.Value = r.Value
.Offset(, 1).Value = r.Offset(, 1).Value
.Offset(, 2).Value = r.Offset(, 2).Value
End With
End With
Else
With sht.Cells(.Rows.Count, 1).End(xlUp).Offset(1)
.Value = r.Value
.Offset(, 1).Value = r.Offset(, 1).Value
.Offset(, 2).Value = r.Offset(, 2).Value
End With
End If
Next
End Sub
You could run a loop from the last row up, moving every row with a matching value; but that could require running through the table several times if not sorted.
You could do it in one loop by filtering a value and transferring all visible cells until none remain.
I would either use the filter method or create an array of unique values and loop through the array without the overhead that comes with filtering.... but it would depend on the table size and context of the application, like if i wanted to keep a filtered table on a 4th sheet.
I currently have this table:
And I would like to categorize it by the last column so it appears as such:
I thought this might be doable with pivot tables or something but it doesn't seem to. I've also tried using a slicer but that doesn't give the desired effect (just hides and unhides rows). This seems like a common and simple enough thing to want to do but I can't seem to figure it out.
Edit:
I don't really want to just recreate the table in the image because the table won't be properly sortable or searchable (since the 'header' rows describing the category will get sorted improperly and come up in the search), I just want it displayed similarly to the image.
Table data:
| Armor | Cost | AC | Strength Requirement | Stealth | Weight | Class |
|-----------------|---------|----|----------------------|--------------|--------|--------------|
| Padded | 5 gp | 11 | — | Disadvantage | 8 lb | Light Armor |
| Leather | 10 gp | 11 | — | — | 10 lb | Light Armor |
| Studded leather | 45 gp | 12 | — | — | 13 lb | Light Armor |
| Hide | 10 gp | 12 | — | — | 12 lb | Medium Armor |
| Chain shirt | 50 gp | 13 | — | — | 20 lb | Medium Armor |
| Scale mail | 50 gp | 14 | — | Disadvantage | 45 lb | Medium Armor |
| Breastplate | 400 gp | 14 | — | — | 20 lb | Medium Armor |
| Half plate | 750 gp | 15 | — | Disadvantage | 40 lb | Medium Armor |
| Ring mail | 30 gp | 14 | — | Disadvantage | 40 lb | Heavy Armor |
| Chain mail | 75 gp | 16 | 13 | Disadvantage | 55 lb | Heavy Armor |
| Splint | 200 gp | 17 | 15 | Disadvantage | 60 lb | Heavy Armor |
| Plate | 1500 gp | 18 | 15 | Disadvantage | 65 lb | Heavy Armor |
| Shield | 10 gp | +2 | — | — | 6 lb | Shield |
You can create your own lookup as follows:
Option Explicit
Public outputRow As Long
'VBE > Tools > references > tick MS HTML Object Library, MS XML
Public Sub Main()
outputRow = 0
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Output") ''change as appropriate
ws.Cells.ClearContents
GetTables ws
AddKeys ws, 1
ws.Cells.Columns.AutoFit
ws.Columns("A:G").NumberFormat = "#"
End Sub
Public Sub GetTables(ByVal ws As Worksheet)
Dim http As New XMLHTTP60, html As New HTMLDocument, arr() As Variant 'XMLHTTP60 This will vary according to your Excel version
arr = Array("Currency", "Armor", "Selling Treasure", "Armor", "Weapons", _
"Adventuring Gear", "Tools", "Mounts and Vehicles", "Trade Goods", "Expenses")
Dim i As Long
For i = LBound(arr) To UBound(arr)
DoEvents
With http
.Open "GET", ConstructURL(LCase$(arr(i))), False
.send
html.body.innerHTML = .responseText
End With
PrintTables html, ws
Next i
End Sub
Public Sub PrintTables(ByVal html As HTMLDocument, ByVal ws As Worksheet)
Dim rng As Range, tbl As HTMLTable, currentRow As Object, currentColumn As Object, i As Long, counter As Long
For Each tbl In html.getElementsByTagName("Table")
counter = counter + 1
outputRow = outputRow + 1
Set rng = ws.Range("B" & outputRow)
rng.Offset(, -1) = "Table " & counter
For Each currentRow In tbl.Rows
For Each currentColumn In currentRow.Cells
rng.Value = currentColumn.outerText
Set rng = rng.Offset(, 1)
i = i + 1
Next currentColumn
outputRow = outputRow + 1
Set rng = rng.Offset(1, -i)
i = 0
Next currentRow
Next tbl
End Sub
Public Function ConstructURL(ByVal item As String) As String
ConstructURL = "https://dnd5e.info/equipment/" & item
End Function
Public Sub AddKeys(ByVal ws As Worksheet, Optional ByVal targetColumn As Long = 1)
Dim loopColumn As Range, rng As Range
Set loopColumn = ws.UsedRange.Columns(targetColumn)
Dim cat As String
For Each rng In loopColumn.Cells
If InStr(1, rng.Text, "Table") > 0 Then
cat = rng.Offset(, 1)
End If
If Not IsEmpty(rng.Offset(, 1)) And Not IsEmpty(rng.Offset(, 2)) Then
If IsEmpty(rng) And Not IsEmpty(rng.Offset(, 2)) Then
rng = cat & rng.Offset(, 1)
End If
If IsEmpty(rng) And IsEmpty(rng.Offset(, 2)) Then
rng = cat & rng.Offset(, 1)
End If
End If
Next rng
End Sub
Output:
Note column A has an unique key that you can use to lookup an item. You will however need to know which column you are interested in, though again you could match on the column header. You can tidy this up but is already suitable for a unique lookup for a given item.
I got data that is stored in one row of columns in an excel sheet.
Is there a way to move data to next row every 4th column? Is there a built in function for this?
For example:
Data:
Actinium | Ac | 89 | 227.0278* | Aluminum | Al | 13 | 26,981539 ...
Output:
Actinium |Ac | 89 | 227.0278*
Aluminum |Al | 13 | 26,981539
I made a macro:
Sub dela_igen()
Dim i As Integer, j As Integer, cur_column As Integer
cur_column = 1
For i = 1 To 100
For j = 1 To 4
Cells(i, j).Value = Cells(1, cur_column).Value
cur_column = cur_column + 1
Next j
Next i
End Sub
Worked like a charm!
I have a table that looks like this:
| A | B | C | D |
+-------+------------+------------+------------+
1 | Name | Language 1 | Language 2 | Language 3 |
+=======+============+============+============+
2 | John | English | Chinese | Spanish |
3 | Wendy | Chinese | French | English |
4 | Peter | Spanish | Chinese | English |
And I want to generate a table that has only one language column. The other two language columns should become new rows like this:
| A | B |
+-------+----------+
1 | Name | Language |
+=======+==========+
2 | John | English |
3 | John | Chinese |
4 | John | Spanish |
5 | Wendy | Chinese |
6 | Wendy | French |
7 | Wendy | English |
8 | Peter | Spanish |
9 | Peter | Chinese |
10 | Peter | English |
I understand this will probably will need a macro or something. If anybody point me in the right direction it would me much appreciate. I am not very familiar with VBA or the Excel object model.
This will do the trick. It is also dynamic supports as many language columns as you want with as many languages per person.
Assumes the data is formatted as per the example:
Sub ShrinkTable()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
Dim newSht As Worksheet
Set newSht = Sheets.Add
With newSht
.Cells(1, 1).Value = "Name"
.Cells(1, 2).Value = "Column"
Dim writeRow As Double
writeRow = 2
Dim row As Double
row = 2
Dim col As Integer
Do While True
col = 2
Do While True
If data(row, col) = "" Then Exit Do 'Skip Blanks
'Name
.Cells(writeRow, 1).Value = data(row, 1)
'Language
.Cells(writeRow, 2).Value = data(row, col)
writeRow = writeRow + 1
If col = maxCols Then Exit Do 'Exit clause
col = col + 1
Loop
If row = maxRows Then Exit Do 'exit cluase
row = row + 1
Loop
End With
End Sub
Messy but should work:
For Each namething In Range("A1", Range("A1").End(xlDown))
Range("A1").End(xlDown).Offset(1, 0) = namething.Value
Range("A1").End(xlDown).Offset(0, 1) = namething.Offset(0, 2)
Range("A1").End(xlDown).Offset(1, 0) = namething.Value
Range("A1").End(xlDown).Offset(0, 1) = namething.Offset(0, 3)
namething.Offset(0, 2) = ""
namething.Offset(0, 3) = ""
Next
Then just sort
The following formula should work. The data in sheet2 would always reflect the data on sheet1 so you wouldn't have to re-run a macro to create a new list.
That being said, using a macro to generate it is probably a better choice as it would allow more flexability should you need to add a 4th language or something at a later date.
In Sheet2!A2
=INDIRECT("Sheet1!A"&ABS(INT((ROW()+1)/3))+1)
In Sheet2!B2
=INDIRECT("Sheet1!"&IF(ABS(INT((ROW()+1)/3)-(ROW()+1)/3)=0,"B",IF(ABS(INT((ROW()+1)/3)-(ROW()+1)/3)=(1/3),"C","D"))&ABS(INT((ROW()+1)/3))+1)
Add the column titles in A1 and B1 then autofill the formula down the sheet.