Related
I am using the code below and it works for filtering the unique name and totalting the value field. I recently have a need to expand upon the filtering of unique names to include other columns in the criteria. Please see the example output I am looking for. Any help would be appreciated.
Sub SUM()
Dim i, j, k As Integer
i = 2
j = 2
Range("D1").Value = "NAME"
Range("E1").Value = "VALUE"
'copy the first value of column A to column D
Range("D2").Value = Range("A2").Value
'cycle to read all values of column B and sum it to column E; will run until find a blank cell
While Range("A" & i).Value <> ""
'this check if actual value of column A is equal to before value of column A, if true just add the column B value to E
'else, look for the row in column D where is the same value of column A, if it doesn't exist code create the value
'in column D and E
If Range("A" & i).Value = Range("A" & i - 1).Value Then
Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
Else
flag = 1
While Range("D" & flag).Value <> ""
If Range("A" & i).Value = Range("D" & flag).Value Then
j = flag
Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
flag = Range("D1").End(xlDown).Row
Else
j = 0
End If
flag = flag + 1
Wend
If j = 0 Then
Range("D1").End(xlDown).Offset(1, 0).Value = Range("A" & i).Value
Range("E1").End(xlDown).Offset(1, 0).Value = Range("B" & i).Value
j = Range("E1").End(xlDown).Row
End If
End If
i = i + 1
Wend
MsgBox "End"
End Sub
Currently outputs like this:
Name Value Name Sum
A 1 A 13
A 2 B 7
B 1 C 3
B 3
C 2
A 1
B 2
A 3
B 1
A 2
A 4
C 1
I would like to have it export data like this example:
Name Code Date Value Name Code Date Sum
A 101 3/10/17 1 A 101 3/10/17 9
A 101 3/10/17 2 A 102 3/10/17 4
B 102 3/10/17 1 B 101 3/10/17 3
B 101 3/10/17 3 B 102 3/10/17 2
C 102 3/8/17 2 B 101 3/8/17 2
A 102 3/10/17 1 C 102 3/8/17 2
B 101 3/8/17 2 C 102 3/10/17 1
A 102 3/10/17 3
B 102 3/10/17 1
A 101 3/10/17 2
A 101 3/10/17 4
C 102 3/10/17 1
As long as your columns go A,B,C,D then F,G,H,I then below code should work. Let me know if it works for you.
Sub CountCodes()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim wbk As Workbook
Dim ws As Worksheet
Dim wsRow As Long, newRow As Long
Dim Names() As String
Dim Found As Boolean
Dim x As Integer, y As Integer, z As Integer, myCount As Integer, mySum As Integer
Dim Cell As Range
Set wbk = ThisWorkbook
Set ws = wbk.Worksheets(1)
ReDim Names(0 To 0) As String
ReDim Codes(0 To 0) As String
ReDim Dates(0 To 0) As String
newRow = 1
With ws
'Find last row of data
wsRow = .Range("A" & .Rows.Count).End(xlUp).Row
'Loop through Column A to fill array
For Each Cell In .Range(.Cells(2, 1), .Cells(wsRow, 1))
'Fill Names array
Found = (IsInArray(Cell.Value2, Names) > -1)
If Found = False Then
Names(UBound(Names)) = Cell.Value2
If Cell.Row <> wsRow Then
ReDim Preserve Names(0 To UBound(Names) + 1) As String
End If
End If
'Fill Codes array
Found = (IsInArray(Cell.Offset(0, 1).Value2, Codes) > -1)
If Found = False Then
Codes(UBound(Codes)) = Cell.Offset(0, 1).Value2
If Cell.Row <> wsRow Then
ReDim Preserve Codes(0 To UBound(Codes) + 1) As String
End If
End If
'Fill Dates array
Found = (IsInArray(Cell.Offset(0, 2).Value2, Codes) > -1)
If Found = False Then
Dates(UBound(Dates)) = Cell.Offset(0, 2).Value
If Cell.Row <> wsRow Then
ReDim Preserve Codes(0 To UBound(Dates) + 1) As String
End If
End If
Next
'Add Autofilter if off
If .AutoFilterMode = False Then
.Range("A1").AutoFilter
End If
For x = LBound(Names) To UBound(Names)
.Range("A1").AutoFilter Field:=1, Criteria1:=Names(x)
For y = LBound(Codes) To UBound(Codes)
.Range("B1").AutoFilter Field:=2, Criteria1:=Codes(y)
For z = LBound(Dates) To UBound(Dates)
.Range("C1").AutoFilter Field:=3, Criteria1:=Dates(z)
For Each Cell In .Range("A1:A" & wsRow).SpecialCells(xlCellTypeVisible)
myCount = myCount + 1
Next
If myCount > 1 Then
For Each Cell In .Range("D2:D" & wsRow).SpecialCells(xlCellTypeVisible)
mySum = mySum + Cell.Value2
Next
'Find last row in new data
newRow = newRow + 1
.Cells(newRow, 6) = Names(x)
.Cells(newRow, 7) = Codes(y)
.Cells(newRow, 8) = Dates(z)
.Cells(newRow, 9) = mySum
End If
myCount = 0
mySum = 0
Next z
Next y
Next x
.ShowAllData
End With
Erase Names
Erase Codes
Erase Dates
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
'http://stackoverflow.com/questions/10951687/how-to-search-for-string-in-an-array
'Boolean = (IsInArray(StringToFind, ArrayToSearch) > -1)
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
I used a pivot table in Excel 2016 to generate this view, since you are not opposed to using a Pivot Table. If Excel can do this out of the box, and you are happy with how it looks and behaves, there is no real need for custom VBA in this case.
Just do the following:
Highlight your data, then insert > pivot table
I placed the pivot table in cell F1 of Sheet 1
Add Name, Code, and Date to the Rows of the pivot table
Add Value to the Values of the pivot table. It should default to Sum.
Click on the pivot table, then in the pivot table tools > design tab in the ribbon, go to the "Layout" ribbon group:
On the Report Layout Dropdown:
Click "Show in Tabular Form"
Click "Repeat All Item Labels"
On the Subtotals Dropdown:
Click "Do Not Show Subtotals"
On the Grand totals Dropdown:
Click "off for rows and columns"
You could use Dictionary object:
Option Explicit
Sub ListTotals()
Dim c As Range, dataRng As Range
Dim key As Variant
Set dataRng = Range("A2", Cells(Rows.Count, 1).End(xlUp))
With CreateObject("Scripting.Dictionary")
For Each c In dataRng
key = Join(c.Resize(,3), "|")
.Item(key) = .Item(key) + c.Offset(,4)
Next c
With dataRng.Resize(.Count)
.Offset(,5) = Application.Transpose(.Keys)
.Offset(,8) = Application.Transpose(.Items)
.Offset(,5).TextToColumns DataType:=xlDelimited, Other:=True, OtherChar:="|", FieldInfo:= Array(Array(1, 2), Array(3, 3))
End With
End With
End Sub
I have researched this extensively but cannot seem to find a solution. I am attempting to create a macro that will compare data between two tables on different sheets and highlight differences using a unique identifier.
Here is an example:
Sheet 1 (Data Set 1)
UniqueID | Name | Date | Status
----------------------------------------
| 1230 | Bob | 1/1/2016 | Denied
| 6985 | Mike | 1/6/2016 | Pending
| 4442 | Will | 1/9/2016 | Approved
Sheet 2 (Data Set 2)
UniqueID | Name | Date | Status
----------------------------------------
| 1230 | Bob | 1/1/2016 | Denied
| 6985 | Mike | 1/6/2016 | Approved
| 4442 | Will | 2/27/2016 | Approved
In this case, the macro would use the shared Unique ID and field name between the data sets and determine the two changes: one to a status field and one to a date field.
Is this possible? Thank you!
if, as per you example, your data sets have UniqueID columns matching each other then you can code like follows:
Option Explicit
Sub main1()
Dim ds1 As Range, ds2 As Range, row As Range, col As Range, f As Range
Set ds1 = Worksheets("DataSet1").Range("A1").CurrentRegion '<--| change "DataSet1" to your actual "Data Set 1" sheet name
Set ds2 = Worksheets("DataSet2").Range("A1").CurrentRegion '<--| change "DataSet2" to your actual "Data Set 2" sheet name
For Each row In ds1.Columns(1).Cells '<--| loop through "Data Set 1" "UniqueID" values (in its column 1)
For Each col In ds1.Rows(row.row).Cells '<--| ...loop through "Data Set 1" "UniqueID" row cells...
If col.Value <> ds2(col.row, col.Column) Then '<--| ... if current cell value doesn't match corresponding "Data Set 2" one, then ...
col.Interior.Color = RGB(255, 0, 0) '<--| ...mark "Data Set 1" current cell...
ds2(col.row, col.Column).Interior.Color = RGB(255, 0, 0) '<--| ...mark corresponding "Data Set 2" one
End If
Next col
Next row
End Sub
otherwise, you must find first find Data Set 1 "UniqueID" corresponding cell in Data Set 2 1st column, like follows:
Option Explicit
Sub main2()
Dim ds1 As Range, ds2 As Range, row As Range, col As Range, f As Range
Set ds1 = Worksheets("DataSet1").Range("A1").CurrentRegion '<--| change "DataSet1" to your actual "Data Set 1" sheet name
Set ds2 = Worksheets("DataSet2").Range("A1").CurrentRegion '<--| change "DataSet2" to your actual "Data Set 2" sheet name
For Each row In ds1.Columns(1).Cells '<--| loop through "Data Set 1" "UniqueID" values (in its column 1)
Set f = ds2.Columns(1).Find(what:=row.Value, LookIn:=xlValues, lookat:=xlWhole) '<--| look for current UniqueID in "Data Set 2" column 1
If Not f Is Nothing Then '<-- if "Data Set 1" "UniqueID" found in "Data Set 2", then...
For Each col In ds1.Rows(row.row).Cells '<--| ...loop through "Data Set 1" "UniqueID" row cells...
If col.Value <> ds2(col.row, col.Column) Then '<--| ... if current cell value doesn't match corresponding "Data Set 2" one, then ...
col.Interior.Color = RGB(255, 0, 0) '<--| ...mark "Data Set 1" current cell...
ds2(col.row, col.Column).Interior.Color = RGB(255, 0, 0) '<--| ...mark corresponding "Data Set 2" one
End If
Next col
End If
Next row
End Sub
If you are looking for a VBA solution, then
if the data set 1 is in sheet Sheet1 and data set 2 in sheet Sheet2 then the below code will highlight the differences in red color.
Sub foo()
For i = 2 To 50 'considering 50 rows in Sheet1
For j = 2 To 50 'considering 50 rows in Sheet2
If Sheets("Sheet1").Cells(i, 1).Value = Sheets("Sheet2").Cells(j, 1).Value Then
For k = 1 To 4
If Sheets("Sheet1").Cells(i, k).Value <> Sheets("Sheet2").Cells(j, k).Value Then
Sheets("Sheet1").Cells(i, k).Interior.Color = RGB(255, 0, 0)
End If
Next k
End If
Next j
Next i
End Sub
Just conditional formatting will do it for you like this:
=B2<>INDEX(H$2:H$4,MATCH($A2,$G$2:$G$4,0))
You will need to change the ranges according to your sheets.
The layout I used was looking like this:
You should try out this code below.
Sub Compare2WorkSheets(ws1 As Worksheet, ws2 As Worksheet)
Dim ws1row As Long, ws2row As Long, ws1col As Integer, ws2col As Integer
Dim maxrow As Long, maxcol As Integer, colval1 As String, colval2 As String
Dim report As Workbook, difference As Long
Dim row As Long, col As Integer
Set report = Workbooks.Add
With ws1.UsedRange
ws1row = .Rows.Count
ws1col = .Columns.Count
End With
With ws2.UsedRange
ws2row = .Rows.Count
ws2col = .Columns.Count
End With
maxrow = ws1row
maxcol = ws1col
If maxrow < ws2row Then maxrow = ws2row
If maxcol < ws2col Then maxcol = ws2col
difference = 0
For col = 1 To maxcol
For row = 1 To maxrow
colval1 = ""
colval2 = ""
colval1 = ws1.Cells(row, col).Formula
colval2 = ws2.Cells(row, col).Formula
If colval1 <> colval2 Then
difference = difference + 1
Cells(row, col).Formula = colval1 & "<> " & colval2
Cells(row, col).Interior.Color = 255
Cells(row, col).Font.ColorIndex = 2
Cells(row, col).Font.Bold = True
End If
Next row
Next col
Columns("A:B").ColumnWidth = 25
report.Saved = True
If difference = 0 Then
report.Close False
End If
Set report = Nothing
MsgBox difference & " cells contain different data! ", vbInformation, "Comparing Two Worksheets"
End Sub
Private Sub CommandButton1_Click()
'Compare2WorkSheets Worksheets("Sheet1"), Worksheets("Sheet2")
Set myWorkbook1 = Workbooks.Open("C:\familycomputerclub-website\Excel2007 \testcompare2.xlsx")
Compare2WorkSheets Workbooks("testcompare1.xlsm").Worksheets("Sheet1"), myWorkbook1.Worksheets("Sheet1")
End Sub
I have a list full of different paths in col A.
I have a list of details in B and C.
How can I on a new sheet: 1) pull each unique path, 2) for each path compile the values from B * C and remove the duplicates. 3) repeat the next path after these are done in the latest row.
I do have a faulty macro, but for the sake of being concise and accurate I will not post. Unless someone wants to read it, please reques
Any help would be greatly appreciated.
Here is what I have(I understand its long, i'll take try to clean it up abit) :
Sub FileDetail()
'Does not fill down, go to bottom to unleased fill down
'Skips unreadable files
'This Macro retrieves data from files picked. The data is based on header. Data is also filtered for unique values.
'You must make sure headers are in the first row and delimted.
Dim wb As Workbook, fileNames As Object, errCheck As Boolean
Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
Dim y As Range, intRow As Long, i As Integer
Dim r As Range, lr As Long, myrg As Range, z As Range
Dim boolWritten As Boolean, lngNextRow As Long
Dim intColNode As Integer, intColScenario As Integer
Dim intColNext As Integer, lngStartRow As Long
Dim lngLastNode As Long, lngLastScen As Long
Dim intColinstrument As Integer, lngLastinstrument As Long
'Skipped worksheet for file names
Dim wksSkipped As Worksheet
Set wksSkipped = ThisWorkbook.Worksheets("Skipped")
' Turn off screen updating and automatic calculation
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Create a new worksheet, if required
On Error Resume Next
Set wksSummary = ActiveWorkbook.Worksheets("Unique data")
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
wksSummary.Name = "Unique data"
End If
' Set the initial output range, and assign column headers
With wksSummary
Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
Set r = y.Offset(0, 1)
Set z = y.Offset(0, -2)
lngStartRow = y.Row
.Range("A1:E1").Value = Array("File Name", "Sheet Name", "Node", "Book", "Instrument")
End With
'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary
On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
Set wb = Nothing ' or set a boolean error flag
End If
On Error GoTo 0 ' or your custom error handler
If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)
Else
Debug.Print "Successfully loaded " & fileNames(Key)
wb.Application.Visible = False 'make it not visible
' more working with wb
' Check each sheet in turn
For Each ws In ActiveWorkbook.Worksheets
With ws
' Only action the sheet if it's not the 'Unique data' sheet
If .Name <> wksSummary.Name Then
boolWritten = False
''''''''''''''''''testing additional column..trouble here
' Find the Anchor Date
intColScenario = 0
On Error Resume Next
intColScenario = WorksheetFunction.Match("instrument.instrumentType", .Rows(1), 0)
On Error GoTo 0
If intColScenario > 0 Then
' Only action if there is data in column E
If Application.WorksheetFunction.CountA(.Columns(intColScenario)) > 1 Then
lr = .Cells(.Rows.Count, intColScenario).End(xlUp).Row
' Copy unique values from the formula column to the 'Unique data' sheet, and write sheet & file details
.Range(.Cells(1, intColScenario), .Cells(lr, intColScenario)).AdvancedFilter xlFilterCopy, , r, True
r.Offset(0, -2).Value = ws.Name
r.Offset(0, -3).Value = ws.Parent.Name
' Delete the column header copied to the list
r.Delete Shift:=xlUp
boolWritten = True
End If
End If
''''''''''''''''''''''''''''''''''''below is working'''''''''''''''''''''''
' Find the Desk column
intColNode = 0
On Error Resume Next
intColNode = WorksheetFunction.Match("book.reportingLine.pathName", .Rows(1), 0)
On Error GoTo 0
If intColNode > 0 Then
' Only action if there is data in column A
If Application.WorksheetFunction.CountA(.Columns(intColNode)) > 1 Then
lr = .Cells(.Rows.Count, intColNode).End(xlUp).Row
' Copy unique values from column A to the 'Unique data' sheet, and write sheet & file details (if not already written)
.Range(.Cells(1, intColNode), .Cells(lr, intColNode)).AdvancedFilter xlFilterCopy, , y, True
If Not boolWritten Then
y.Offset(0, -1).Value = ws.Name
y.Offset(0, -2).Value = ws.Parent.Name
End If
' Delete the column header copied to the list
y.Delete Shift:=xlUp
End If
End If
' Find the Intrument
intColinstrument = 0
On Error Resume Next
intColinstrument = WorksheetFunction.Match("instrument.instrumentType", .Rows(1), 0)
On Error GoTo 0
If intColinstrument > 0 Then
' Only action if there is data in column A
If Application.WorksheetFunction.CountA(.Columns(intColinstrument)) > 1 Then
lr = .Cells(.Rows.Count, intColinstrument).End(xlUp).Row
' Copy unique values from column A to the 'Unique data' sheet, and write sheet & file details (if not already written)
.Range(.Cells(1, intColinstrument), .Cells(lr, intColinstrument)).AdvancedFilter xlFilterCopy, , z, True
If Not boolWritten Then
z.Offset(0, -3).Value = ws.Name
z.Offset(0, -4).Value = ws.Parent.Name
End If
' Delete the column header copied to the list
z.Delete Shift:=xlUp
End If
End If
' Identify the next row, based on the most rows used in columns C & D
lngLastNode = wksSummary.Cells(wksSummary.Rows.Count, 3).End(xlUp).Row
lngLastScen = wksSummary.Cells(wksSummary.Rows.Count, 4).End(xlUp).Row
lngLastinstrument = wksSummary.Cells(wksSummary.Rows.Count, 5).End(xlUp).Row
lngNextRow = WorksheetFunction.Max(lngLastNode, lngLastScen) + 1
If (lngNextRow - lngStartRow) > 1 Then
' Fill down the workbook and sheet names
z.Resize(lngNextRow - lngStartRow, 2).FillDown
''''''''Optional if you want headers to be filled down.
'If (lngNextRow - lngLastNode) > 1 Then
' Fill down the last Node value
'wksSummary.Range(wksSummary.Cells(lngLastNode, 3), wksSummary.Cells(lngNextRow - 1, 3)).FillDown
'End If
'If (lngNextRow - lngLastScen) > 1 Then
' Fill down the last Scenario value
'wksSummary.Range(wksSummary.Cells(lngLastScen, 4), wksSummary.Cells(lngNextRow - 1, 4)).FillDown
'End If
End If
Set y = wksSummary.Cells(lngNextRow, 3)
Set r = y.Offset(0, 1)
Set z = y.Offset(0, -2)
lngStartRow = y.Row
End If
End With
Next ws
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If
Next 'End of the fileNames loop
Set fileNames = Nothing
' Autofit column widths of the report
wksSummary.Range("A1:E1").EntireColumn.AutoFit
' Reset system settings
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.Visible = True
End With
End Sub
So this code gets file name, sheet name, and columns I specify's data.
1) However I am having trouble adding additional columns to this. (I currently get 2 extracted columns), and also
2) I am having trouble putting it in a format where it columns are based upon each other. ex It will give me unique value for each path, but then not the unique values per sport.
Edit to include data ( I also would like to include a 4th and 5th column but kept it to 3 for simplicity):
+-------------------------------+------------+--------------+
| path | sport | Teams |
+-------------------------------+------------+--------------+
| stack/over/flow/larrybird | basketball | celtics |
+-------------------------------+------------+--------------+
| stack/over/flow/michaeljordan | basketball | bulls |
+-------------------------------+------------+--------------+
| stack/over/flow/tigerwoods | golf | pga |
+-------------------------------+------------+--------------+
| stack/over/flow/josebautista | baseball | bluejays |
+-------------------------------+------------+--------------+
| stack/over/flow/jordanspeith | golf | pga |
+-------------------------------+------------+--------------+
| stack/over/flow/kevinlove | basketball | timberwolves |
+-------------------------------+------------+--------------+
| stack/over/flow/lebronjames | basketball | cavs |
+-------------------------------+------------+--------------+
| stack/over/flow/stephencurry | basketball | warriors |
+-------------------------------+------------+--------------+
| stack/over/flow/larrybird | baseball | redsox |
+-------------------------------+------------+--------------+
| stack/over/flow/michaeljordan | baseball | whitesox |
+-------------------------------+------------+--------------+
| stack/over/flow/michaeljordan | chess | knight |
+-------------------------------+------------+--------------+
| stack/over/flow/michaeljordan | basketball | hornets |
+-------------------------------+------------+--------------+
| stack/over/flow/kevinlove | basketball | cavs |
+-------------------------------+------------+--------------+
| stack/over/flow/tigerwoods | golf | pga |
+-------------------------------+------------+--------------+
And expected result (I included fill down in this)
+-------------------------------+------------+--------------+
| path | sport | teams |
+-------------------------------+------------+--------------+
| stack/over/flow/larrybird | basketball | celtics |
+-------------------------------+------------+--------------+
| | baseball | red sox |
+-------------------------------+------------+--------------+
| stack/over/flow/tigerwoods | golf | pga |
+-------------------------------+------------+--------------+
| stack/over/flow/michaeljordan | basketball | bulls |
+-------------------------------+------------+--------------+
| | | hornets |
+-------------------------------+------------+--------------+
| | baseball | whitesox |
+-------------------------------+------------+--------------+
| | chess | knight |
+-------------------------------+------------+--------------+
| stack/over/flow/kevinlove | basketball | timberwolves |
+-------------------------------+------------+--------------+
| | | cavs |
+-------------------------------+------------+--------------+
| stack/over/flow/josebautista | baseball | bluejays |
+-------------------------------+------------+--------------+
It seems to be an issue for the 3rd (4th and 5th also) columns with getting unique values.
The easy way would be, to copy the whole range, sort it and then run some calculations:
Sub Macro1()
Application.ScreenUpdating = False
Dim str As String
With Sheet1
str = .Range(.Cells(.Rows.Count, 1).End(xlUp), .Cells(1, 3)).Address
.Range(str).Copy Sheet2.Cells(1, 1)
End With
Application.CutCopyMode = False
With Sheet2
.Activate
Dim str2 As String
str2 = .Range(str).Offset(1).Resize(.Range(str).Rows.Count - 1).Address
.Range(str2).Value = Evaluate("if(" & str2 & "="""",-1E+99," & str2 & ")")
.Sort.SortFields.Clear
.Sort.SortFields.Add .Range(str).Offset(1).Resize(, 1), 0, 1, , 0
.Sort.SortFields.Add .Range(str).Offset(1, 1).Resize(, 1), 0, 1, , 0
.Sort.SortFields.Add .Range(str).Offset(1, 2).Resize(, 1), 0, 1, , 0
.Sort.SetRange .Range(str).Offset(1)
.Sort.Header = 2
.Sort.Apply
.Range(str2).Value = Evaluate("if(" & str2 & "=-1E+99,""""," & str2 & ")")
Dim val As Variant, i As Long, rng2 As Range
val = .Range(str).Value
Set rng2 = .Range(str).Offset(.Range(str).Rows.Count).Resize(1)
For i = 3 To UBound(val)
If val(i - 1, 1) = val(i, 1) And val(i - 1, 2) = val(i, 2) And val(i - 1, 3) = val(i, 3) Then Set rng2 = Union(rng2, .Range(str).Rows(i))
Next
i = .Range(str).Rows.Count - rng2.Rows.Count
rng2.EntireRow.Delete xlShiftUp
With .Range(str).Offset(1).Resize(i - 1, 1)
.Value = Evaluate("if(" & .Address & "=" & .Offset(-1).Address & ",""""," & .Address & ")")
With .Offset(, 1)
.Value = Evaluate("if((" & .Address & "=" & .Offset(-1).Address & ")*(" & .Offset(, -1).Address & "=""""),""""," & .Address & ")")
End With
End With
End With
End Sub
Done by phone, may contain errors!
Changed a lot now, please copy the whole code and test it again.
EDIT
Ok, a completely different solution. Should be fast, but may not be very clear in the way it works :P
Sub Macro2()
Dim inVal As Variant, outVal() As Variant, orderArr() As Variant
Dim startRng As Range
Dim i As Long, j As Long, k As Long, iCount As Long
Set startRng = Sheet1.Range("A2:C2") 'upmost row-range of the range to be copied (exclude headers!)
With startRng.Parent
inVal = .Range(startRng, .Cells(.Rows.Count, startRng.Column).End(xlUp)).Value
End With
ReDim orderArr(1 To UBound(inVal))
For i = 1 To UBound(inVal)
iCount = 1
For j = 1 To UBound(inVal)
For k = 1 To UBound(inVal, 2)
If StrComp(inVal(i, k), inVal(j, k), 1) = 1 Then iCount = iCount + 1
If StrComp(inVal(i, k), inVal(j, k), 1) <> 0 Then Exit For
Next
Next
orderArr(i) = iCount
Next
k = 1
ReDim outVal(1 To UBound(inVal, 2), 1 To UBound(inVal))
For i = 0 To Application.Max(orderArr)
If IsNumeric(Application.Match(i, orderArr, 0)) Then
iCount = Application.Match(i, orderArr, 0)
For j = 1 To UBound(inVal, 2)
outVal(j, k) = inVal(iCount, j)
Next
k = k + 1
End If
Next
ReDim Preserve outVal(1 To UBound(inVal, 2), 1 To k - 1)
For i = 1 To UBound(outVal)
For j = UBound(outVal, 2) To 2 Step -1
If outVal(i, j - 1) = outVal(i, j) Then
If i = 1 Then
outVal(i, j) = ""
ElseIf outVal(i - 1, j) = "" Then
outVal(i, j) = ""
End If
End If
Next
Next
'upper left cell of the output-range
Sheet2.Range("A2").Resize(UBound(outVal, 2), UBound(outVal)).Value = Application.Transpose(outVal)
End Sub
Feel free to set the starting range (Sheet1.Range("A2:C2")) to Selection and then simply select the range and start the macro. Does work with any size (while VERY big ranges may freeze excel for some time).
As always: if you have any questions, just ask :)
One efficient solution would be to:
Fisrt copy the values with Range.Copy
Then sort the rows with Range.Sort
Then remove the duplicated rows with Range.RemoveDuplicates
Finally remove the duplicated branches with a loop
This procedure removes the duplicated rows and format as a tree view:
Sub RemoveDuplicates()
Dim rgSource As Range, rgTarget As Range, data(), r&, c&
' define the source, the target and the number of columns
Const columnCount = 3
Set rgSource = Range("Sheet1!A3")
Set rgTarget = Range("Sheet1!F3")
' copy the values to the targeted range
Set rgSource = rgSource.Resize(rgSource.End(xlDown).Row - rgSource.Row + 1, columnCount)
Set rgTarget = rgTarget.Resize(rgSource.Rows.Count, columnCount)
rgSource.Copy rgTarget
' sort the rows on each column
For c = columnCount To 1 Step -1
rgTarget.Sort rgTarget.Columns(c)
Next
' build the array of columns for RemoveDuplicates
Dim rdColumns(0 To columnCount - 1)
For c = 1 To columnCount: rdColumns(c - 1) = c: Next
' remove the duplicated rows
rgTarget.RemoveDuplicates rdColumns
Set rgTarget = rgTarget.Resize(rgTarget.End(xlDown).Row - rgTarget.Row + 1, columnCount)
' format as a tree view by removing the duplicated branches
data = rgTarget.Value
For r = UBound(data) To 2 Step -1
For c = 1 To columnCount - 1
If data(r, c) <> data(r - 1, c) Then Exit For
data(r, c) = Empty
Next
Next
rgTarget.Value = data
End Sub
If you don't mind having the results sorted, instead of in the original order, the following code will do that. It should "auto-adapt" to any number of columns.
(If you need the results in the original order, I would use Collections or Dictionaries and User Defined Object approach)
Your data should start in A1 (with Row 1 being the column labels) and you can see where, in the code, you define the Worksheets for your Source and Results data.
Since most of the "work" is done within a VBA array, rather than on the worksheet, it should run quite rapidly.
Option Explicit
Sub SortFormat()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vRes As Variant
Dim R As Range, C As Range
Dim V As Variant
Dim I As Long, J As Long
'Set source and results worksheets, ranges
Set wsSrc = Worksheets("Sheet1")
Set wsRes = Worksheets("Sheet2")
wsRes.Cells.Clear
Set rRes = wsRes.Cells(1, 1)
Application.ScreenUpdating = False
'Copy source data to results worksheet
Dim LastRow As Long, LastCol As Long
With wsSrc
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set R = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
R.Copy rRes
Application.CutCopyMode = False
End With
'Go to Results sheet
With wsRes
.Select
.UsedRange.EntireColumn.AutoFit
End With
rRes.Select
'Sort the data
With wsRes.Sort.SortFields
.Clear
Set R = wsRes.UsedRange.Columns
For Each C In R
.Add Key:=C, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Next C
End With
With wsRes.Sort
.SetRange R
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
'Remove any completely duplicated rows
'Create array of columns
ReDim V(0 To R.Columns.Count - 1)
For I = 0 To UBound(V)
V(I) = I + 1
Next I
R.RemoveDuplicates Columns:=(V), Header:=xlYes
'Remove Duplicated items in each row
'Work in VBA array for more speed
vRes = R
For I = UBound(vRes, 1) To 3 Step -1
If vRes(I, 1) = vRes(I - 1, 1) Then vRes(I, 1) = ""
For J = 2 To UBound(vRes, 2)
If vRes(I, J) = vRes(I - 1, J) And _
vRes(I, J - 1) = "" Then vRes(I, J) = ""
Next J
Next I
R = vRes
Application.ScreenUpdating = True
End Sub
If you want to make a unique list of anything, use a Dictionary object.
Make sure to add a reference to the Scripting Runtime controls! Just some quick and dirty code (as in completely untested) based on your sample data:
Sub GetUniques()
Dim oDic as New Dictionary
Dim r as Integer
Dim strKey as String
Dim varValue(2) as Variant
'Get a unique list of Column A values
r = 3 'Your data starts on row 3
Do While Cells(r,1).value <> "" 'Run until the first blank line
strKey = Cells(r,1).value
varValue(0) = Cells(r,2).Value
varValue(1) = Cells(r,3).Value
If Not oDic.Exists(strKey) Then
oDic.Add strKey, varValue
End If
r = r +1
Loop
'Now display your list of unique values
Dim K as Variant
Dim myArray as Variant
r = 3 'We'll start on row 3 again but move over to column I (9)
For Each K in oDic.Keys
Cells(r,9).Value = K
myArray = oDic.Item(K)
Cells(r,10).Value = myArray(0)
Cells(r,11).Value = myArray(1)
r = r + 1
Next K
End Sub
I need help in creating a macro in Excel wherein it grabs a certain cell and copies the entire row x number of times depending on the cell's contents.
To make it clear, let's say I have 2 rows:
| Order # | Item | Qty |
| 30001 | bag | 3 |
| 30002 | pen | 1 |
What I want the macro to do is grab the number under the Qty column and copy the entire row and insert a new line with the exact same contents under it. The number of times it does this depends on the number in the Qty cell. Also, it appends a three digit number in the Order # cell to make it a unique reference point. What the end-result should be:
| Order # | Item | Qty |
| 30001-001 | bag | 1 |
| 30001-002 | bag | 1 |
| 30001-003 | bag | 1 |
| 30002-001 | pen | 1 |
It's hard to explain it here but I hope you get the point. Thanks in advance, gurus!
The following code supports blank lines in the middle of the data.
If Qty = 0, it won't write the Item in the output table.
Please insert at least 1 row of data, because it won't work if there is no data :)
Option Explicit
Sub caller()
' Header at Row 1:
' "A1" = Order
' "B1" = Item
' "C1" = Qty
'
' Input Data starts at Row 2, in "Sheet1"
'
' Output Data starts at Row 2, in "Sheet2"
'
' Sheets must be manually created prior to running this program
Call makeTheThing(2, "Sheet1", "Sheet2")
End Sub
Sub makeTheThing(lStartRow As Long, sSheetSource As String, sSheetDestination As String)
Dim c As Range
Dim rOrder As Range
Dim sOrder() As String
Dim sItem() As String
Dim vQty As Variant
Dim sResult() As String
Dim i As Long
' Reads
With ThisWorkbook.Sheets(sSheetSource)
Set rOrder = .Range(.Cells(lStartRow, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)) ' It will work if there are blank lines in the middle!
i = rOrder.Rows.Count
ReDim sOrder(1 To i)
ReDim sItem(1 To i)
ReDim vQty(1 To i)
i = 1
For Each c In rOrder
sOrder(i) = Trim(c.Text)
sItem(i) = Trim(c.Offset(0, 1).Text)
vQty(i) = c.Offset(0, 2).Value
i = i + 1
Next c
End With
' Processes
sResult = processData(sOrder, sItem, vQty)
' Writes
ThisWorkbook.Sheets(sSheetDestination).Range("A" & lStartRow).Resize(UBound(sResult, 1), UBound(sResult, 2)).Value = sResult
End Sub
Function processData(sOrder() As String, sItem() As String, vQty As Variant) As String()
Dim i As Long
Dim j As Long
Dim k As Long
Dim sResult() As String
j = WorksheetFunction.Sum(vQty) ' That's why vQty had to be Variant!
ReDim sResult(0 To j, 1 To 3)
k = 0
For i = 1 To UBound(sOrder)
For j = 1 To vQty(i)
sResult(k, 1) = sOrder(i) & "-" & Format(j, "000")
sResult(k, 2) = sItem(i)
sResult(k, 3) = "1"
k = k + 1
Next j
Next i
processData = sResult
End Function
I hope it helps you. I had fun making it!
One way: Walk down the qty column inserting as needed then jumping to the next original row;
Sub unwind()
Dim rowCount As Long, cell As Range, order As String, i As Long, r As Long
Set cell = Range("C1")
rowCount = Range("C" & rows.Count).End(xlUp).Row
For i = 1 To rowCount
order = cell.Offset(0, -2).Value
For r = 0 To cell.Value - 1
If (r > 0) Then cell.Offset(r).EntireRow.Insert
cell.Offset(r, 0).Value = 1
cell.Offset(r, -1).Value = cell.Offset(0, -1).Value
cell.Offset(r, -2).Value = order & "-" & Format$(r + 1, "000")
Next
Set cell = cell.Offset(r, 0)
Next
End Sub
So i have a matrix formatted as so:
| | joe | michelle | tom |
|:-----: |:---: |:--------: |:---: |
| red | 1 | 0 | 1 |
| blue | 0 | 1 | 0 |
| green | 0 | 0 | 0 |
I'm trying to write VBA in excel to create two columns based on this table. If the cell inside the matrix is equal to "1", then I want to write the column name and row name into a list. So for example, because row "red" has a "1" in columns "joe" and "tom", and row "blue" has a "1" under "michelle", my new table would be like this:
| joe | red |
| tom | red |
| michelle | blue |
Here is the VBA i wrote so far, but it doesn't work and i hit a road block.
sub subname()
dim i as integer
for i = 1 to 3
if cells(2,i).value=1 then
cell(5,i).value = cells(1,i).value
end if
next i
end sub
You have only one cycle ...
Dim x As Integer
Range("B19").Select
x = 4
For i = 1 To 3 ' Row
For e = 1 To 3 ' Column
If ActiveCell.Offset(i, e).Value = "1" Then
x = x + 1
ActiveCell.Offset(x, 0).Value = ActiveCell.Offset(0, e).Value
ActiveCell.Offset(x, 1).Value = ActiveCell.Offset(i, 0).Value
End If
Next
Next
I consider B19 the top_left corner of the table ...
Ok the correct code is:
Dim i As Integer
For i = 1 To 3
If Cells(2, i + 1).Value = 1 Then
Cells(5, 1).Value = Cells(1, i + 1).Value
End If
Next i
If the top_left of the table is A1 The error is the reference of i. You need to add 1 or change the cycle from 2 to 4.The second "error" it's to put the value in cell(5,i) instead of cells(5,1). In that case you have to put the name in a fix position. In a cycle you change in Cells(5+e,1)...
You can use this code also.
Sub prabhat()
Dim rng As Range
Dim r As Integer
Dim c As Integer
Dim lastRow As Integer
Dim lastRow2 As Integer
Set rng = Range("a2:d4")
For Each dng In rng
lastRow = Range("E" & Rows.Count).End(xlUp).Row
lastRow2 = Range("F" & Rows.Count).End(xlUp).Row
If dng.Value = 1 Then
r = dng.Row
c = dng.Column
Range("E" & lastRow + 1).Value = Cells(r, 1).Value
Range("F" & lastRow2 + 1).Value = Cells(1, c).Value
End If
Next dng
End Sub