I have the following code to copy all unique values from the range in the tab as defined below, to a single column in the "Summary" tab:
Sub GetUniqueItems()
Dim vData As Variant, n&, lLastRow&, sMsg$
Dim oColl As Collection
lLastRow = Worksheets(Worksheets("Summary").Range("A1").Value)._
Cells(Rows.Count, "H").End(xlUp).Row
If lLastRow = 1 Then Exit Sub
vData = Worksheets(Worksheets("Summary").Range("A1").Value)._
Range("H2:H" & lLastRow)
Set oColl = New Collection
For n = LBound(vData) To UBound(vData)
On Error Resume Next
oColl.Add vData(n, 1), CStr(vData(n, 1))
On Error GoTo 0
Next n
For n = 1 To oColl.Count
sMsg = oColl(n)
Sheets("Summary").Cells(n + 3, 1).Value = Mid$(sMsg, 1)
Next n
End Sub
This works great for the defined range. What I want to do though is copy from a dynamic range from the defined tab. This range will be defined by the last column with an entry in row 1 and the last filled row between column A and the last column. It seems though that as soon as I introduce a lastcol variable, or a range that includes multiple columns the code brings up an error.
The code as I have built so far is:
Sub GetUniqueItems()
Dim vData As Variant, n&, lLastRow&, sMsg$
Dim oColl As Collection
Dim lastrow As Long
Dim lLastCol As Long
'Find last column in Row 1 of each data tab
lLastCol = Worksheets(Worksheets("Summary").Range("A1").value)._
Cells(1, Columns.Count).End(xlToLeft).Column
If lLastCol < 1 Then Exit Sub
' Find the last row of the last column
lLastRow = Worksheets(Worksheets("Summary").Range("A1").value)._
Cells(Rows.Count, lLastCol).End(xlUp).Row
If lLastRow = 1 Then Exit Sub
vData = Worksheets(Worksheets("Summary").Range("A1").value).Range(llastcol)
Set oColl = New Collection
For n = LBound(vData) To UBound(vData)
If Not (IsDate(vData(n, 1)) Or IsEmpty(vData(n, 1))) Then oColl._
Add (vData(n, 1)), CStr(vData(n, 1))
On Error GoTo 0
Next n
For n = 1 To oColl.Count
sMsg = oColl(n)
Sheets("Summary").Cells(n + 3, 1).value = Mid$(sMsg, 1)
Sheets("Summary").Cells(n + 3, 1).Offset(0, 1).value = _
Application.CountIf(Worksheets(Range(Split(Sheets("Summary")._
Cells(n + 3, 1).Address, "$")(1) & "1").value).Cells, Mid$(sMsg, 1))
Next n
End Sub
Any suggestions?
The error I get is due to .Range(lLastCol), where lLastCol is an integer.
If you want to select the column with that index, use .Columns(lLastCol) instead.
The next error I ran into was due to the fact that I was trying to add duplicates to oColl. I used the same trick as in your first sample so overcome this and got past the error.
The next error is somewhere in the last line of code before the last Next n. There's probably an off-by-one or some logic error, but I'll trust you can take it from here.
My code:
Sub GetUniqueItems_Dynamic()
Dim vData As Variant, n&, lLastRow&, sMsg$
Dim oColl As Collection
Dim lastrow As Long
Dim lLastCol As Long
'Find last column in Row 1 of each data tab
lLastCol = Worksheets(Worksheets("Summary").Range("A1").Value). _
Cells(1, Columns.Count).End(xlToLeft).Column
If lLastCol < 1 Then Exit Sub
' Find the last row of the last column
lLastRow = Worksheets(Worksheets("Summary").Range("A1").Value). _
Cells(Rows.Count, lLastCol).End(xlUp).Row
If lLastRow = 1 Then Exit Sub
vData = Worksheets(Worksheets("Summary").Range("A1").Value).Columns(lLastCol)
Set oColl = New Collection
For n = LBound(vData) To UBound(vData)
On Error Resume Next
If Not (IsDate(vData(n, 1)) Or IsEmpty(vData(n, 1))) Then oColl. _
Add (vData(n, 1)), CStr(vData(n, 1))
On Error GoTo 0
Next n
For n = 1 To oColl.Count
sMsg = oColl(n)
Sheets("Summary").Cells(n + 3, 1).Value = Mid$(sMsg, 1)
Sheets("Summary").Cells(n + 3, 1).Offset(0, 1).Value = _
Application.CountIf(Worksheets(Range(Split(Sheets("Summary"). _
Cells(n + 3, 1).Address, "$")(1) & "1").Value).Cells, Mid$(sMsg, 1))
Next n
End Sub
Related
I have a spreadsheet that has values that looks similar to below :
Is there any possible way to create VBA to join all the separate data together for each ID and Class into one row? So that the ending result would look like below?
Sub JoinRowsData()
Dim lastRow As Long, i As Long, j As Long, k As Long
Application.ScreenUpdating = False
lastRow = Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
For j = i + 1 To lastRow
If Cells(i, 2) = Cells(j, 2) Then
For k = 5 To 10
If (Cells(i, k) = "" And Cells(j, k) <> "") Then
Cells(i, k) = Cells(j, k)
End If
Next
End If
Next
Next
Application.ScreenUpdating = True
End Sub
The following will do it. See the comments for an explanation how it works. It uses arrays to process the data which is much faster than process cells directly.
Option Explicit
Public Sub JoinRowsData()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long ' get last used row in worksheet
LastRow = GetLastUsed(xlByRows, ws)
Dim LastCol As Long ' get last used column in worksheet
LastCol = GetLastUsed(xlByColumns, ws)
' Read data into an array for faster processing
Dim Data() As Variant
Data = ws.Range("A1", ws.Cells(LastRow, LastCol)).Value2
' define an output array with the same size
Dim Output() As Variant
ReDim Output(1 To UBound(Data, 1), 1 To UBound(Data, 2))
Dim outRow As Long ' output row index
Dim iRow As Long
For iRow = 1 To LastRow ' loop through all rows in data
' if column 1 contains data it is a new output row
If Data(iRow, 1) <> vbNullString Then
outRow = outRow + 1
End If
' loop through all columns in a data row
Dim iCol As Long
For iCol = 1 To LastCol
If Data(iRow, iCol) <> vbNullString Then ' check if current cell has data
If Output(outRow, iCol) <> vbNullString Then
' add a line break if there is already data in the output cell
Output(outRow, iCol) = Output(outRow, iCol) & vbLf
End If
' add the data to the output cell
Output(outRow, iCol) = Output(outRow, iCol) & Data(iRow, iCol)
End If
Next iCol
Next iRow
' write all the output data from the array back to the cells
ws.Range("A1", ws.Cells(LastRow, LastCol)).Value2 = Output
End Sub
' find last used row or column in worksheet
Public Function GetLastUsed(ByVal RowCol As XlSearchOrder, ByVal InWorksheet As Worksheet) As Long
With InWorksheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
Dim LastCell As Range
Set LastCell = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=RowCol, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If RowCol = xlByRows Then
GetLastUsed = LastCell.Row
Else
GetLastUsed = LastCell.Column
End If
Else
GetLastUsed = 1
End If
End With
End Function
I need some help with comparing values from one column to another and delating it.
so far I have this:
Sub DelateDuplicates()
delArray = Sheets("Save").Range("B1:B") ' saved values
toDelate = Sheets("Validation").Range("B2:B").Value ' values to be checked and delated
lastRow = toDelate.Range("B1000").End(xlUp).Row ' last row
Firstrow = toDelate.Range("B2").End(xlDown).Row ' First row
Dim i As Long
For Lrow = lastRow To Firstrow Step -1
With Worksheets("Validation").Cells(Lrow, "A")
For i = 0 To UBound(delArray) ' arrays are indexed from zero
If Not IsError(.Value) Then
If .Value = delArray(i) Then
.EntireRow.Delete
Exit For
End If
End If
Next
End With
Next Lrow
End Sub
And I do have an error.
"1004 "Application-defined or Object-defined error" "
I have spent 2 days trying to figure it out so far no luck.
Any help will be appreciated.
I modified your code little bit. You can define your first rows and last row the want you want, I have kept it simple for the sake of concept
Option Explicit
Sub DelateDuplicates()
Dim Lrow As Long
Dim delarray()
With Worksheets("Save")
delarray = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
Dim i As Long
Dim lastrow As Long
Dim firstrow As Long
firstrow = 1
With Worksheets("Validation")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Lrow = lastrow To firstrow Step -1
For i = 1 To UBound(delarray)
If Not IsError(.Cells(Lrow, "A").Value) Then
If .Cells(Lrow, "A").Value = delarray(i, 1) Then
.Cells(Lrow, "A").EntireRow.Delete
Exit For
End If
End If
Next i
Next Lrow
End With
End Sub
You can avoid loops within loops by using a Dictionary Object
Option Explicit
Sub DeleteDuplicates()
Dim wsSave As Worksheet, wsValid As Worksheet
Dim iLastRow As Long, iFirstRow As Long, i As Long, n As Long
Dim dict As Object, key, cell As Range
With ThisWorkbook
Set wsSave = .Sheets("Save")
Set wsValid = Sheets("Validation")
End With
Set dict = CreateObject("Scripting.Dictionary")
' get values to delete from Column B
For Each cell In wsSave.Range("B1", wsSave.Cells(Rows.Count, "B").End(xlUp))
key = Trim(cell)
If Len(key) > 0 Then
dict(key) = cell.Row
End If
Next
' scan Validation sheet and delete matching from Save
With wsValid
iFirstRow = .Cells(2, "B").End(xlDown).Row
iLastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For i = iLastRow To iFirstRow Step -1
key = .Cells(i, "A")
If dict.exists(key) Then
.Rows(i).Delete
n = n + 1
End If
Next
End With
' resutl
MsgBox n & " rows deleted between row " & _
iFirstRow & " and " & iLastRow, vbInformation
End Sub
I have multiple rows in a spreadsheet set up like the following:
TEST 1 Y N TEST_1 1234 Derived
TEST_2 56
I need to split the cells that have a line break while copying the remaining cells into the new row:
TEST 1 Y N TEST_1 1234 Derived
TEST 1 Y N TEST_2 56 Derived
I tested code by changing line breaks to commas (I don't know the VBA symbol for linebreak). The code I tried only works for one column E, not Column F:
Sub splitByCol()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet1").Range("E999999:F999999").End(xlUp)
Do While r.row > 1
ar = Split(r.value, ",")
If UBound(ar) >= 0 Then r.value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
I just did a brief test, might not be perfect. If you have a ton of rows and columns this might be a tad slow aswell.
Dim rowiter As Long
Dim coliter As Long
Dim lastrow As Long
Dim lastcol As Long
Dim rowcount As Long
Dim rowadd As Boolean
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastcol = .Cells.Find(What:="*", after:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
rowcount = lastrow + 1
For rowiter = 1 To lastrow
rowadd = False
For coliter = 1 To lastcol
If InStr(1, .Cells(rowiter, coliter), vbLf) Then
.Cells(rowcount, coliter).Value = Split(.Cells(rowiter, coliter), vbLf)(1)
.Cells(rowiter, coliter).Value = Split(.Cells(rowiter, coliter), vbLf)(0)
rowadd = True
End If
Next
If rowadd = True Then
For coliter = 1 To lastcol
If .Cells(rowcount, coliter).Value = "" Or IsNull(.Cells(rowcount, coliter).Value) Then
.Cells(rowcount, coliter).Value = .Cells(rowiter, coliter).Value
End If
Next
rowcount = rowcount + 1
End If
rowadd = False
Next
.Range(Cells(1, 1), Cells(rowcount, lastcol)).Sort Key1:=Columns("A"), Order1:=xlDescending
End With
Actually you were almost there:
You need to split by vbLf instead of ","
You need to split column E and F into seperate arrays
So you end up with:
Option Explicit
Sub splitByCol()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim CurrentCell As Range
Set CurrentCell = ws.Range("E" & ws.Rows.Count).End(xlUp)
Dim ArrE As Variant 'split array for column E
Dim ArrF As Variant 'split array for column F
Do While CurrentCell.Row > 1
ArrE = Split(CurrentCell.Value, vbLf)
ArrF = Split(CurrentCell.Offset(ColumnOffset:=1).Value, vbLf)
If UBound(ArrE) >= 0 Then CurrentCell.Value = ArrE(0)
If UBound(ArrF) >= 0 Then CurrentCell.Offset(ColumnOffset:=1).Value = ArrF(0)
Dim i As Long
For i = UBound(ArrE) To 1 Step -1
CurrentCell.EntireRow.Copy
CurrentCell.Offset(1).EntireRow.Insert
CurrentCell.Offset(1).Value = ArrE(i)
If UBound(ArrF) >= i Then
CurrentCell.Offset(1, 1).Value = ArrF(i)
Else
CurrentCell.Offset(1, 1).Value = vbNullString
End If
Next i
Set CurrentCell = CurrentCell.Offset(-1)
Loop
End Sub
Input
Output
I want to remove duplicates based on the text in Column I and sum the values in Column C, the data in the other columns doesn't matter.
I do not want a pivot table and I am aware they are the preferred option for this type of thing.
An example of what I'd like to achieve:
I found VBA code and tried to modify it. It doesn't delete all the lines.
Sub Sum_and_Dedupe()
With Worksheets("data")
'deal with the block of data radiating out from A1
With .Cells(1, 1).CurrentRegion
'step off the header and make one column wider
With .Resize(.Rows.Count - 1, .Columns.Count + 1).Offset(1, 0)
.Columns(.Columns.Count).Formula = "=sumifs(c:c, i:i, i2)"
.Columns(3) = .Columns(.Columns.Count).Value
.Columns(.Columns.Count).Delete
End With
'remove duplicates
.RemoveDuplicates Columns:=Array(9), Header:=xlYes
End With
.UsedRange
End With
End Sub
This should be an answer to your question.
However, code might require adaptation if the range in which you look becomes very long.
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim LastRow As Long, LastCol As Long, a As Double, i As Long
Dim Rng As Range
Dim Cell As Variant, Estimate As Variant
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
LastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set Rng = ws.Range(ws.Cells(2, 9), ws.Cells(LastRow, 9))
For Each Cell In Rng
i = 0
a = 0
For Each Estimate In Rng
If Estimate.Value = Cell.Value Then
i = i + 1 'Count nr of intances
a = a + ws.Cells(Estimate.Row, 3).Value 'sum booking value
If i > 1 Then
ws.Rows(Estimate.Row).Delete
i = 1
LastRow = LastRow - 1
End If
End If
Next Estimate
ws.Cells(Cell.Row, 3).Value = a 'Enter sum in booked this week
Next Cell
End Sub
You'll either need to change your current sheet name to data, or change the first two lines of this code to fit your needs. sh = the data sheet that you showed us. osh = an output sheet that this code will generate. Note also if column C or I move you can update the positions easily by changing colBooked and colEstimate. If you have more than a thousand unique estimate entries then make the array number larger than 999.
Sub summariseEstimates()
Dim sh As String: sh = "data"
Dim osh As String: osh = "summary"
Dim colBooked As Integer: colBooked = 3
Dim colEstimate As Integer: colEstimate = 9
Dim myArray(999) As String
Dim shCheck As Worksheet
Dim output As Worksheet
Dim lastRow As Long
Dim a As Integer: a = 0
Dim b As Integer
Dim r As Long 'row anchor
Dim i As Integer 'sheets
'Build summary array:
With Worksheets(sh)
lastRow = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For r = 2 To lastRow
If r = 2 Then 'first entry
myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
Else
For b = 0 To a
If VBA.LCase(VBA.Replace(.Cells(r, colEstimate), " ", "")) = VBA.LCase(VBA.Replace(VBA.Split(myArray(b), ",")(0), " ", "")) Then 'match
myArray(b) = VBA.Split(myArray(b), ",")(0) & "," & VBA.Split(myArray(b), ",")(1) + .Cells(r, colBooked)
Exit For
End If
Next b
If b = a + 1 Then 'completed loop = no match, create new array item:
a = a + 1
myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
End If
End If
Next r
End With
'Create summary sheet:
On Error Resume Next
Set shCheck = Worksheets(osh)
If Err.Number <> 0 Then
On Error GoTo 0
Set output = Worksheets.Add(After:=Worksheets(sh))
output.Name = osh
Err.Clear
Else
On Error GoTo 0
If MsgBox("*" & osh & "* sheet already exists. Proceed to delete and recreate?", vbOKCancel, "Summary") = vbCancel Then
Exit Sub
Else
Application.DisplayAlerts = False
Worksheets(osh).Delete
Set output = Worksheets.Add(After:=Worksheets(sh))
output.Name = osh
End If
End If
'Output to summary sheet:
With Worksheets(osh)
.Cells(1, 1).Value = "ESTIMATE"
.Cells(1, 2).Value = "BOOKED THIS WEEK"
For b = 0 To a
.Cells(b + 2, 1).Value = VBA.Split(myArray(b), ",")(0)
.Cells(b + 2, 2).Value = VBA.Split(myArray(b), ",")(1)
Next b
.Columns("A:B").AutoFit
End With
End Sub
I'm trying to get my code to insert four rows every time it finds a difference in the cell below. If A5-55 = 1, A56-80 = 2, A81 - 100 = 3 I want the code to see that 56 isn't equal to 55 and insert 4 rows, then continue down the A column until there are no more values.
I keep getting an error from Excel,
can not complete task. Resources error
And then a runtime 1004 insert method of range class failed, and the debugger highlights the code for inserting rows
This is what my data looks like:
Worksheets("HR-Calc").Activate
For lRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row To 6 Step -1
If Cells(lRow, "A") <> Cells(lRow - 1, "A") Then
Rows(lRow).EntireRow.Insert
Rows(lRow).EntireRow.Insert
Rows(lRow).EntireRow.Insert
Rows(lRow).EntireRow.Insert
End If
Next lRow
A neater way would be to use an autofilter on the table
(The code assumes that column A is a sorted integer ID - as seems to be the case from the image)
Sub InsertRowsBetweenIncrements()
Dim ws As Worksheet: Set ws = Worksheets("HR-Calc")
Dim HeaderRow As Long: HeaderRow = 4
Application.ScreenUpdating = False
Dim LastRow As Long: LastRow = ws.Columns(1).Find("*", _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim LastCol As Long: LastCol = ws.Cells.Find("*", _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Dim Tbl As Range: Set Tbl = ws.Range(Cells(HeaderRow, 1), Cells(LastRow, LastCol))
Dim i As Long, j As Long
For i = ws.Cells(LastRow, 1).Value To 1 Step -1
Tbl.AutoFilter Field:=1, Criteria1:=i
j = Tbl.SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeLastCell).Row
Tbl.AutoFilter
If j <> HeaderRow And j < LastRow Then _
ws.Rows(j + 1 & ":" & j + 4).Insert Shift:=xlDown
Next i
Application.ScreenUpdating = True
End Sub
If you want a less-clunky was (as you mentioned), I would default to using arrays to increase speed. Give the code below a try and see what you think. This assumes your data starts in row 6 (if not, change the value of "offset" to the final row before the data in question starts). If you want to change how many rows you insert in the future, just change the value of rows_to_insert to the desired number.
Sub insertrows()
Dim check_col() As Variant
Dim rng As Range
Dim lcell As Range
Dim i As Long
Dim rows_to_insert As Long
Dim rows_added As Long
Dim offset As Long
Dim insert_cell As Long
Worksheets("HR-Calc").Activate
lrow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set lcell = Cells(lrow, 1)
Set rng = Range("A6", lcell)
check_col = rng
rows_to_insert = 4
rows_added = 0
offset = 5
rows_added = 0
For i = 1 To (UBound(check_col, 1) - 1)
If check_col(i, 1) <> check_col(i + 1, 1) Then
check_col(i, 1) = i + rows_added + offset
rows_added = rows_added + rows_to_insert
Else: check_col(i, 1) = VBnllstring
End If
Next i
check_col(UBound(check_col, 1), 1) = vbNullString
rows_to_insert = rows_to_insert - 1
For i = 1 To UBound(check_col, 1)
If check_col(i, 1) <> vbNullString Then
insert_cell = check_col(i, 1) + 1
Range(Cells(insert_cell, 1), Cells(insert_cell + rows_to_insert, 1)).EntireRow.Select
Range(Cells(insert_cell, 1), Cells(insert_cell + rows_to_insert, 1)).EntireRow.Insert
End If
Next i
End Sub