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!
Related
Macro to keep on going to the next cell till the value doesn't match and for all the similar values, subtract the values from the bottom most row
Essentially my data is like this (There is only one buy for each name and it is the bottom most cell)
Name | Transaction.Type | Amount | Remaining (what macro needs to do)
Name1 | Sell | 5 | 15 (20-5)
Name1 | Sell | 10 | 10 (20-10)
Name1 | Sell | 15 | 5 (20-15)
Name1 | Buy | 20 |
Name2 | Sell | 25 | 5
Name2 | Buy | 30 |
So far my macro looks like
Dim sline As Integer
Dim eline As Integer
Dim rng As Range
Dim lastrow(1 To 3) As Long
Application.DisplayAlerts = False
With Worksheets("Testing Data 2")
lastrow(1) = .Cells(Rows.Count, "A").End(xlUp).Row
End With
For i = 2 To 4151
If Worksheets("Testing Data 2").Range("A" & i) <> Worksheets("Testing Data 2").Range("A" & i).Offset(1, 0) Then
eline = i
Worksheets("Testing Data 2").Range(":C" & eline)
'struggling to go from here
End If
Next i
Application.DisplayAlerts = True
You can do this without VBA with the understanding that each Name only has one instnace of Buy
=SUMIFS(C:C,A:A,A3,B:B,"Buy")-C2 'Drag down as needed
I've been scouring stackoverflow and haven't found what I am looking for. Which is frustrating because I know I can't be the only one who has come across this.
I have an excel spreadsheet with 26k rows -- and I need to purge all rows where column D and E have same values -- except I want to keep at most 10 rows and purge rest. In some instances there will only be 3 duplicate rows so those can stay.
Here is example of my spreadsheet.
+------+-------+--------+---------+---------+
| Code | Local | Number | Place A | Place B |
+------+-------+--------+---------+---------+
| A | 558 | 25 | DEW | ABE |
+------+-------+--------+---------+---------+
| A | 485 | 14 | DEW | FXD |
+------+-------+--------+---------+---------+
| A | 658 | 85 | DEW | ABE |
+------+-------+--------+---------+---------+
| A | 225 | 68 | ABE | FXD |
+------+-------+--------+---------+---------+
| A | 1 | 56 | ABE | FXD |
+------+-------+--------+---------+---------+
| A | 47 | 412 | DEW | CDE |
+------+-------+--------+---------+---------+
Imagine I had 15 rows where Place A and Place B were DEW and ABE -- I would want to delete 5 of those. I don't care what 5, just 5 have to go and I need to be left with 10.
Tim Williams' comment will do exactly what you're after and is far simpler than a VBA solution:
Public Sub FilterRange(ByRef TargetTable As Range, ByVal TargetColumns As Variant, Optional ByVal MaxDuplicateCount As Long = 10, _
Optional ByVal IsCaseSensitive As Boolean = False, Optional ByVal Delimiter As String = "^&")
Dim Temp As Variant, x As Long, y As Long
'Error checking
If Not IsArray(TargetColumns) Then
MsgBox "Target columns must be provided as a one dimensional array i.e. ""Array(1, 4, 5)"" ", vbCritical
Exit Sub
End If
'More error checking
For x = 0 To UBound(TargetColumns, 1)
If Not IsNumeric(TargetColumns(x)) Then
MsgBox "Invalid column number supplied: " & TargetColumns(x), vbCritical
Exit Sub
ElseIf TargetColumns(x) < 1 Then
MsgBox "Invalid column number supplied: " & TargetColumns(x), vbCritical
Exit Sub
ElseIf TargetColumns(x) > TargetTable.Columns.Count Then
MsgBox "Invalid column number supplied: " & TargetColumns(x), vbCritical
Exit Sub
End If
Next x
'Create Dictionary object
Dim DuplicateCounter As Object, ThisRowVal As Variant
Set DuplicateCounter = CreateObject("Scripting.Dictionary")
'Set Dictionary case sensitivity
If IsCaseSensitive Then
DuplicateCounter.CompareMode = 0
Else
DuplicateCounter.CompareMode = 1
End If
'Pull table into an array
Temp = TargetTable.Value
'Check each row in the array
For x = 1 To UBound(Temp, 1)
'Determine this row's unique value (based on the supplied columns)
ThisRowVal = Empty
For y = 0 To UBound(TargetColumns, 1)
ThisRowVal = ThisRowVal & Temp(x, TargetColumns(y)) & Delimiter
Next y
'Check for duplicates
If DuplicateCounter.Exists(ThisRowVal) Then
If DuplicateCounter(ThisRowVal) >= MaxDuplicateCount Then
'Too many with this unique value, delete the excess row data
For y = 1 To UBound(Temp, 2)
Temp(x, y) = Empty
Next y
Else
'We haven't exceeded the max row count: increment the counter
DuplicateCounter(ThisRowVal) = DuplicateCounter(ThisRowVal) + 1
End If
Else
'This value is new: add to dictionary with a count of 1
DuplicateCounter.Add ThisRowVal, 1
End If
Next x
'Write the output data to the table range
TargetTable.Value = Temp
End Sub
If you put the above code into a module, you can write the below into a command button, or type it into the Immediate window.
FilterRange Sheets("Sheet1").Range("A1:E26000"), Array(4, 5)
As this pulls the data into an array, it will operate quickly, but will overwrite the table range with values (formulas will be lost). I've written some self-describing optional parameters that allow you to change the code's behaviour.
I was wondering how to paste filtered data into the same corresponding rows but another column.
I have a filtered Table in Excel like this:
#Row | A | B
1 | foo |
5 | bar |
8 | fish |
Now I want to paste values from Column A into B maintaining the row position.
#Row | A | B
1 | foo | foo
2 | |
3 | |
4 | |
5 | bar | bar
... | |
... | |
8 | fish | fish
the normal paste method pastes the values as a consecutive block.
last = db_ws.Rows(Rows.Count).End(xlUp).Row
db_ws.Range("A11:BC" & last).SpecialCells(xlCellTypeVisible).Copy
tgt_ws.Range("A11").PasteSpecial
Any help appreciated.
Code snippet:
Dim i as Long
last = db_ws.Rows(Rows.Count).End(xlUp).Row
For i = 11 to last
If db_ws.Range("A"& i).EntireRowHidden=False Then
tgt_ws.Range("A"& i).Value = db_ws.Range("A" & i).Value
tgt_ws.Range("B" & i).Value = db_ws.Range("A" & i).Value
End If
Next i
For completion of the topic here you go with the array solution.
count = -1 ' array has to start with 0
On Error GoTo errHndlr:
For Each cl In rng.SpecialCells(xlCellTypeVisible)
count = count + 1
ReDim Preserve arr(count)
arr(count) = cl.Row
Debug.Print cl.Row
Next cl
errHndlr:
For Each Item In arr
db_ws.Cells(Int(Item), 55) = db_ws.Cells(Int(Item), 1).Value
Next Item
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
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.