Related
I have a project I am working on that entails looping through a series of worksheets, each of which is named after a series of values in a separate sheet. I then perform some functions on each sheet, adding a formula to the next empty column. However, my code is erroring out at this line:
Worksheets(Name).Range(.Cells(2, LastColumn + 1)).Formula = "=F2"
The specific error is
"Application-defined or Object-defined error"
and I'm not sure why this is occurring. I've switched up the way I reference the worksheets, moving around the With-blocks etc. Note that this is just a Sub where I've been testing out different components of the full macro. Any help on this error or what I'm doing wrong would be appreciated!
Sub Test()
Dim ws2 As Worksheet
Dim wb As Workbook
Dim LastRow As Long, LastColumn As Long
Dim LastRow2 As Long
Dim Name As Variant, SheetR As Variant
Set wb = ActiveWorkbook
Set ws2 = wb.Sheets("Comm")
LastRow2 = 6
'sort each sheet on date descending
With wb
SheetR = ws2.Range("A3:A" & (LastRow2 + 2))
For Each Name In SheetR
LastColumn = 0
LastRow = 0
With Worksheets(Name)
Worksheets(Name).Rows("1:1").AutoFilter
Worksheets(Name).AutoFilter.Sort.SortFields.Add Key:=Range("H1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Worksheets(Name).AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
LastColumn = Worksheets(Name).Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = Worksheets(Name).Cells(Rows.Count, 1).End(xlUp).Row
If LastRow = 1 Then
ElseIf LastRow = 2 Then
ElseIf LastRow = 3 Then
ElseIf LastRow = 4 Then
ElseIf LastRow > 4 Then
'The error is occurring at this next line
Worksheets(Name).Range(.Cells(2, LastColumn + 1)).Formula = "=F2"
Worksheets(Name).Range(.Cells(3, LastColumn + 1)).Formula = "=F3+O2"
Worksheets(Name).Range(.Cells(3, LastColumn + 1)).Select
Selection.AutoFill Destination:=Sheets(CStr(Name)).Range(.Cells(4, LastColumn + 1), .Cells(LastRow, LastColumn + 1)), Type:=xlFillDefault
Else
End If
End With
Next Name
End With
End Sub
Look at my annotation.
Sub Test()
Dim ws2 As Worksheet, wb As Workbook, LastRow As Long, LastColumn As Long, LastRow2 As Long, Name As Variant, SheetR As Variant
Set wb = ActiveWorkbook
Set ws2 = wb.Sheets("Comm")
LastRow2 = 6
'sort each sheet on date descending
SheetR = ws2.Range("A3:A" & (LastRow2 + 2))
For Each Name In SheetR
LastColumn = 0
LastRow = 0
With Worksheets(Name)
.Rows("1:1").AutoFilter
.AutoFilter.Sort.SortFields.Add Key:=.Range("H1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'Added "." before the Key range
With .AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column 'Added "." before Columns.Count
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Added "." before Rows.Count
If LastRow = 1 Then
ElseIf LastRow = 2 Then
ElseIf LastRow = 3 Then
ElseIf LastRow = 4 Then
ElseIf LastRow > 4 Then
'The error is occurring at this next line
.Cells(2, LastColumn + 1).Formula = "=F2" 'Removed .range() as this is only a single cell being called
.Cells(3, LastColumn + 1)).Formula = "=F3+O2" 'Removed .range() as this is only a single cell being called
.Cells(3, LastColumn + 1)).Select 'Removed .range() as this is only a single cell being called
Selection.AutoFill Destination:=Sheets(CStr(Name)).Range(.Cells(4, LastColumn + 1), .Cells(LastRow, LastColumn + 1)), Type:=xlFillDefault 'Need to check your qualifiers in this line... using source, not destination
Else
End If
End With
Next Name
End Sub
Edit1: Fixed innapropriate call for range() on a single cell. Props to u/PeterT for calling it out
You've taken the time to build a With Worksheets(Name) ... End With block but failed to take advantage of it. Additionally, .Range(.Cells(...)) is bad syntax unless you provide two .Cells for a start and stop.
To rewrite your With Worksheets(Name) ... End With block,
...
With Worksheets(Name)
.Rows("1:1").AutoFilter
.AutoFilter.Sort.SortFields.Add Key:=.Range("H1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If LastRow = 1 Then
ElseIf LastRow = 2 Then
ElseIf LastRow = 3 Then
ElseIf LastRow = 4 Then
ElseIf LastRow > 4 Then
'The error is occurring at this next line
.Cells(2, LastColumn + 1).Formula = "=F2"
.Cells(3, LastColumn + 1).Formula = "=F3+O2"
.Cells(3, LastColumn + 1).AutoFill Destination:=.Range(.Cells(4, LastColumn + 1), .Cells(LastRow, LastColumn + 1)), Type:=xlFillDefault
Else
End If
End With
...
I would like to select the top 10 Values from Main table and paste in different range (E3) and REMAINING all values and PASTE and SUM in another range(I3)
I used the code below. It is working for Top 10 values, BUT for remaining,
when i am adding one more row in Main table, it is not working. Help me.
Private Sub CommandButton1_Click()
'Calculation for Top 10 Countries
Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Offset(-9, -2).Resize(10, 3).Copy Sheets("Sheet1").Range("E3")
'Calculation for Remaining Countries
Range("A3:C14").Copy Range("I3")
Range("I15").Select
ActiveCell.FormulaR1C1 = "Remaining"
Range("J15").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)"
Range("K15").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)"
End Sub
Please try this code.
Option Explicit
Private Sub CommandButton1_Click()
Dim Rng As Range
Dim R As Long, Rl As Long ' last row
With Worksheets("Sheet1")
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
R = Application.Max(Rl - 9, 3)
' pick Top 10 Countries
Set Rng = Range(.Cells(R, "A"), .Cells(Rl, "C"))
Rng.Copy Destination:=.Cells(3, "E")
' pick remaining countries
If R > 3 Then
Set Rng = Range(.Cells(3, "A"), .Cells(R - 1, "C"))
Rng.Copy Destination:=.Cells(3, "I")
' write totals
Rl = .Cells(.Rows.Count, "I").End(xlUp).Row
Set Rng = Range(.Cells(3, "J"), .Cells(Rl, "J"))
Rl = Rl + 1
With .Cells(Rl, "I")
.Value = "Remaining"
.HorizontalAlignment = xlRight
.Font.Bold = True
End With
With .Cells(Rl, "J")
.Value = Application.Sum(Rng)
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
With .Cells(Rl, "K")
.Value = Application.Sum(Rng.Offset(0, 1))
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
End If
End With
End Sub
Private Sub CommandButton1_Click()
Dim lr As Long
Dim pr As Long
With Sheets("Sheet1")
lr = .Range("A" & Rows.Count).End(xlUp).Row
'Calculation for Top 10 Countries
.Range("A" & (lr - 10) & ":C" & lr).Copy .Range("E3")
'Calculation for Remaining Countries
.Range("A3:C" & (lr - 11)).Copy .Range("I3")
pr = .Range("A3:C" & (lr - 11)).Rows.Count + 3
.Range("I" & pr).Value = "Remaining"
.Range("J" & pr).FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)"
.Range("K" & pr).FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)"
End With
End Sub
The code below first sorts the main table by country (hard-coded option), then creates 2 copies of the sorted table in columns E and I sorted descending or ascending (hard-coded option), and deletes the part in each which isn't needed. The user can choose the year by which the ranking is to be determined, and the program allows for more years to be added to the main table and processed without change of code. You may wish to change the name of the worksheet in the code.
Option Explicit
Private Sub CommandButton1_Click()
' 14 Nov 2017
Dim Ws As Worksheet
Dim ClmCount As Long
Dim SortYear As Long ' = column in main table
Dim SortOrder As XlSortOrder
Dim Rng As Range
Dim Rl As Long, Rend As Long ' last row
Dim R As Long, C As Long
Set Ws = Worksheets("Deepak")
SortYear = YearToSort(Ws)
If SortYear Then ' exit if cancelled
Application.ScreenUpdating = False
With Ws
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
If Rl > 3 Then ' skip, if no list
ClmCount = MainTableColumnsCount(Ws)
' === Sorting the main table
' you can sort on another column, in another order
' or skip the sort entirely
' to skip remove these two lines of code
Set Rng = Range(.Cells(3, "A"), .Cells(Rl, ClmCount))
SortRange Rng, 1, xlAscending ' sort Main by country (column 1)
' === set the sort order for Lists 1 & 2 here:-
SortOrder = xlAscending ' Alt: change for xlDescending
SheetSetup Ws, SortYear, SortOrder ' create sorted copies
' List 1: delete all but the top 10
C = ClmCount + 2
R = IIf(SortOrder = xlAscending, 3, 13)
Rend = IIf(SortOrder = xlAscending, Rl - 10, Rl)
Set Rng = Range(.Cells(R, C), .Cells(Rend, C + ClmCount - 1))
Rng.Delete Shift:=xlUp
' List 2: delete the top 10
C = 2 * (ClmCount + 1) + 1
R = IIf(SortOrder = xlAscending, Rl - 9, 3)
Rend = IIf(SortOrder = xlAscending, Rl, 12)
Set Rng = Range(.Cells(R, C), .Cells(Rend, C + ClmCount - 1))
Rng.Delete Shift:=xlUp
' write totals
Rl = .Cells(.Rows.Count, C).End(xlUp).Row
With .Cells(Rl + 1, C)
.Value = "Remaining"
.HorizontalAlignment = xlRight
.Font.Bold = True
End With
For C = (C + 1) To (C + ClmCount - 1)
Set Rng = Range(.Cells(3, C), .Cells(Rl, C))
With .Cells(Rl + 1, C)
.Value = Application.Sum(Rng)
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
Next C
End If
End With
Application.ScreenUpdating = True
End If
End Sub
Private Sub SortRange(Rng As Range, _
SortColumn As Long, _
SortOrder As XlSortOrder)
' 14 Nov 2017
With Rng.Worksheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Rng.Columns(SortColumn), _
SortOn:=xlSortOnValues, _
Order:=SortOrder, _
DataOption:=xlSortNormal
.SetRange Rng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Private Function YearToSort(Ws As Worksheet) As Long
' 14 Nov 2017
' return the column number of the main table
' return 0 if cancelled
Dim Fun As Long
Dim Rng As Range
Dim UserInput As String
Set Rng = Ws.Range(Cells(2, 2), Cells(2, MainTableColumnsCount(Ws)))
' use B2 as default
Do
UserInput = InputBox("Enter the year to sort by:", _
"Select a year", Rng.Cells(1).Value)
If UserInput = "" Then Exit Do
On Error Resume Next
Fun = Application.Match(CLng(UserInput), Rng, 0)
If Err Then
MsgBox "There is no data for year " & UserInput & "." & vbCr & _
"Please enter an available year.", _
vbInformation, "Invalid input"
UserInput = ""
On Error GoTo 0
End If
Loop While UserInput = ""
YearToSort = Fun + 1
End Function
Private Sub SheetSetup(Ws As Worksheet, _
SortYear As Long, _
SortOrder As XlSortOrder)
' 14 Nov 2017
Const Captions As String = "Top 10 countries,All other countries"
Dim Rng As Range, SortRng As Range
Dim ClmCount As Long
Dim Rl As Long ' last row
Dim C As Long
Dim i As Long
With Ws
Rl = .Cells(.Rows.Count, 1).End(xlUp).Row
ClmCount = MainTableColumnsCount(Ws)
C = .UsedRange.Columns.Count
If C > ClmCount Then
' delete all existing except main table
Set Rng = Range(.Cells(1, ClmCount + 1), .Cells(Rl, C))
Rng.Cells.Delete Shift:=xlUp
End If
Set Rng = Range(.Cells(1, 1), .Cells(Rl, ClmCount))
' create two copies of the main table
For i = 1 To 2
C = (ClmCount + 1) * i + 1
Rng.Copy Destination:=.Cells(1, C)
.Cells(1, C + 1).Value = Split(Captions, ",")(i - 1)
Set SortRng = Range(.Cells(3, C), .Cells(Rl, C + ClmCount - 1))
SortRange SortRng, SortYear, SortOrder
Next i
End With
End Sub
Private Function MainTableColumnsCount(Ws As Worksheet) As Long
' 14 Nov 2017
Dim Fun As Long
Do
Fun = Fun + 1
Loop While Len(Ws.Cells(2, Fun).Value)
MainTableColumnsCount = Fun - 1
End Function
You could do it with formulas as well. In the G3 cell type:
=LARGE(C$3:C$200, ROW()-2)
for finding the top country. In F3 and E3 insert:
=INDEX(B$3:B$200, MATCH(G3,C$3:C$200,0))
and
=INDEX(A$3:A$200, MATCH(G3,C$3:C$200,0))
respectively. Then drag then down to 12th row. You have top 10 now. In the cell K3 type:
=IFERROR(LARGE(C$3:C$200, ROW()+8),"")
and in J3 and I3:
=IFERROR(INDEX(B$3:B$200, MATCH(K3,C$3:C$200,0)),"")
and
=IFERROR(INDEX(A$3:A$200, MATCH(K3,C$3:C$200,0)),"")
Then drag then down several screens. There is less than 200 countries and territories on the world, so it should be enough. If there is no macros, you don'tneed the button, everything will update on fly.
I modified the code only at one point because it was what I needed but I need something extra and I can't figure out how to do it.
Here is the original code from this post :
Sub test()
Dim lastRow As Integer, i As Integer
Dim cel As Range, rng As Range, sortRng As Range
Dim curString As String, nextString As String
Dim haveHeaders As Boolean
haveHeaders = False ' Change this to TRUE if you have headers.
lastRow = Cells(1, 1).End(xlDown).Row
If haveHeaders Then 'If you have headers, we'll start the ranges in Row 2
Set rng = Range(Cells(2, 1), Cells(lastRow, 1))
Set sortRng = Range(Cells(2, 1), Cells(lastRow, 2))
Else
Set rng = Range(Cells(1, 1), Cells(lastRow, 1))
Set sortRng = Range(Cells(1, 1), Cells(lastRow, 2))
End If
' First, let's resort your data, to get all of the "Column A" values in order, which will group all duplicates together
With ActiveSheet
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange sortRng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Now, let's move all "Column B" data for duplicates into Col. C
' We can check to see if the cell's value is a duplicate by simply counting how many times it appears in `rng`
Dim isDuplicate As Integer, firstInstanceRow As Integer, lastInstanceRow As Integer
If haveHeaders Then
curString = Cells(2, 1).Value
Else
curString = Cells(1, 1).Value
End If
Dim dupRng As Range 'set the range for the duplicates
Dim k As Integer
k = 0
For i = 1 To lastRow
If i > lastRow Then Exit For
Cells(i, 1).Select
curString = Cells(i, 1).Value
nextString = Cells(i + 1, 1).Value
isDuplicate = WorksheetFunction.CountIf(rng, Cells(i, 1).Value)
If isDuplicate > 1 Then
firstInstanceRow = i
Do While Cells(i, 1).Offset(k, 0).Value = nextString
'Cells(i, 1).Offset(k, 0).Select
lastInstanceRow = Cells(i, 1).Offset(k, 0).Row
k = k + 1
Loop
Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Copy
Cells(firstInstanceRow, 5).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete
k = 0
lastRow = Cells(1, 1).End(xlDown).Row
End If
Next i
End With
End Sub
What I did is:
changed this:
Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 2)).Copy
Cells(firstInstanceRow, 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
to
Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Copy
Cells(firstInstanceRow, 5).PasteSpecial xlPasteValues
Application.CutCopyMode = False
What I have is:
Column A has duplicates.
Column B has unique value.
And column C has the qty for the unique values.
It works until the copy and paste part with the exception that it copies either column C under value from column B or the other way is that it copies each value from Column B with the qty from Column C but when it finishes, it deletes all the duplicates.
Example
Column A Column B column C
322 sku322 qty 20
322 322sku qty 25
it outputs like
Column D column E
sku322 qty 20
322sku qty 25
And when it's finished, it delete the second row. This means that i don't have the second unique value.
Or it outputs like:
Column D Column E
sku322 322sku
qty 20 qty 25
And then it delete the last row and I don't have the qty anymore.
From my way of thinking if there is no way to paste on the same line, that would mean that after each find it should retake the loop and not copy/paste in bulk. But I tried multiple ways and can't seem to find a way to make it work.
Hows this? Screenshot of the results:
Note: If you want the ENTIRE 'unique-sku' column instead of just the country code, change
country = Right(Cells(i, 2), 2)
to
country = Cells(i, 2).Value
Code:
Sub Macro1()
'
' Macro1 Macro
'
Dim country As String, qty As Integer
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' Headers
dict("country") = "sum"
' Loop through all rows starting on row 2; per Column A
For i = 2 To Sheets("Sheet1").Cells(1, 1).End(xlDown).Row
' Country = last 2 letters of Column B
country = Right(Cells(i, 2), 2)
qty = CInt(Cells(i, 3).Value)
' If it already exists, add the new amount to the sum.
If dict.Exists(country) Then
qty = dict(country) + qty
End If
' This will create it if it doesn't already exist. Otherwise, update.
dict(country) = qty
Next
' Here are some display options.
' Horizontal
Range("F2").Resize(1, UBound(dict.Keys()) + 1).Value = dict.Keys()
Range("F3").Resize(1, UBound(dict.Items()) + 1).Value = dict.Items()
' Vertical
Range("F5").Resize(UBound(dict.Keys()) + 1).Value = WorksheetFunction.Transpose(dict.Keys())
Range("G5").Resize(UBound(dict.Items()) + 1).Value = WorksheetFunction.Transpose(dict.Items())
Set dict = Nothing
'
End Sub
So i found a workaround, i don't know if it's the most feasable one but it works and for 10.000 rows it does it in 40 seconds to 1 minute max.
You need to create 3 modules and a function (i did not want to put the function in the on the modules.
Module 1
Sub Simplify()
Application.Run "Module9.RemovePart"
Application.Run "Module10.SameRowDuplicates"
End Sub
Module 2
Private Sub RemovePart()
Dim fndList As Variant
Dim fndRplc As Variant
With ActiveSheet
Range("B1").EntireColumn.Insert 'Here i inserted a new column so i can duplicate the first column
Range("A1", Range("A" & Rows.Count).End(xlUp)).Copy ' Copied the first column to the inserted one
Range("B1", Range("B" & Rows.Count).End(xlUp)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
Application.CutCopyMode = False
lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' selected first column to remove the end of the sku
fndList = Array("FR", "DE", "ES") ' here you can just change to whatevery you want to remove
fndRplc = "" ' here is what it replaces it with
For x = LBound(fndList) To UBound(fndList)
For i = lastRow To 1 Step -1
Range("A1").EntireColumn.Replace What:=fndList(x), Replacement:=fndRplc, _
LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next i
Next x
End With
End Sub
Module 3
Private Sub SameRowDuplicates()
Dim lastRow As Integer, i As Integer
Dim cel As Range, Rng As Range, sortRng As Range
Dim curString As String, nextString As String
Dim haveHeaders As Boolean
haveHeaders = True ' Change this to TRUE if you have headers.
lastRow = Cells(1, 1).End(xlDown).Row
If haveHeaders Then 'If you have headers, we'll start the ranges in Row 2
Set Rng = Range(Cells(2, 1), Cells(lastRow, 1))
Set sortRng = Range("A2").CurrentRegion
Else
Set Rng = Range(Cells(1, 1), Cells(lastRow, 1))
Set sortRng = Range("A1").CurrentRegion
End If
' First, let's resort your data, to get all of the "Column A" values in order, which will group all duplicates together
With ActiveSheet
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange sortRng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Now, let's move all "Column B" data for duplicates into Col. C
' We can check to see if the cell's value is a duplicate by simply counting how many times it appears in `rng`
Dim isDuplicate As Integer, firstInstanceRow As Integer, lastInstanceRow As Integer
If haveHeaders Then
curString = Cells(2, 1).Value
Else
curString = Cells(1, 1).Value
End If
Dim dupRng As Range 'set the range for the duplicates
Dim k As Integer
k = 0
For i = 1 To lastRow
If i > lastRow Then Exit For
Cells(i, 1).Select
curString = Cells(i, 1).Value
nextString = Cells(i + 1, 1).Value
isDuplicate = WorksheetFunction.CountIf(Rng, Cells(i, 1).Value)
If isDuplicate > 1 Then
firstInstanceRow = i
Do Until Cells(i, 1).Offset(k, 0).Value <> nextString
'Cells(i, 1).Offset(k, 0).Select
lastInstanceRow = Cells(i, 1).Offset(k, 0).Row
k = k + 1
Loop
Cells(firstInstanceRow, 5).Formula = "=Combine(" & Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Address(False, False) & ")" ' combine the results in one row so you have all the duplicates one after another
Cells(firstInstanceRow, 5).Copy
Cells(firstInstanceRow, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
Application.CutCopyMode = False
Selection.TextToColumns DataType:=xlDelimited, _ ' this is for converting comma delimited to columns
ConsecutiveDelimiter:=False, Semicolon:=True ' here you should change your delimiter to what you are using
Range(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete
k = 0
lastRow = Cells(1, 1).End(xlDown).Row
End If
Next i
End With
End Sub
Function 1
Function Combine(WorkRng As Range, Optional Sign As String = ";") As String
'Update 20130815
Dim Rng As Range
Dim OutStr As String
For Each Rng In WorkRng
If Rng.Text <> ";" Then
OutStr = OutStr & Rng.Text & Sign
End If
Next
Combine = Left(OutStr, Len(OutStr) - 1)
End Function
So quick story:
Module 1 calls for the other modules, i did it this way to make things easier for the end-user so he doesn't see all the modules just needs to click one.
Module 2 removes any text from the selected cells
Module 3 finds the duplicates and puts them on one line delimited by what you select in the function module. And then deletes the duplicates row.
Function 1 takes the output of you selection and puts it on one row delimited.
That is all, thanks for everybody's help and i wish this will help others.
I am new to coding and i cant seem to solve this problem. I am trying to copy and paste some ranges from one worksheet to another. When doing so, I continue to be prompted with an error message when the code attempts to activate the new worksheet. The Code is below. The error occurs when trying to active the "Summary" sheet before copying and pasting the ranges.
Sub nxt()
LR = Cells(Rows.Count, "A").End(xlUp).Row
Last = Cells(Rows.Count, "D").End(xlUp).Row
clryellow = RGB(256, 256, 0)
ThisWorkbook.Sheets("Rankings").Select
Sheets("Rankings").Select
ActiveSheet.Range("A1:H1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Rankings").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Rankings").AutoFilter.Sort.SortFields.Add Key:= _
Range("H1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Rankings").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ThisWorkbook.Sheets("Summary").Activate
Sheets("Summary").Select
Sheets("Summary").Range("A8:A18").Value = Sheets("Rankings").Range("A2:A12").Value
Sheets("Summary").Range("B8:B18").Value = Sheets("Rankings").Range("E2:E12").Value
Sheets("Summary").Range("C8:C18").Value = Sheets("Rankings").Range("G2:G12").Value
Sheets("Summary").Range("D8:D18").Value = Sheets("Rankings").Range("H2:H12").Value
ActiveWorkbook.Sheets("Summary").Activate
With ActiveSheet
For x = Last To 8 Step -1
If (Cells(x, "D").Value) >= 6 Then
Cells(x, "A").EntireRow.Delete
ElseIf (Cells(x, 4).Value) < 6 Then
Cells(x, 1).Interior.Color = clryellow
Cells(x, 1).Font.Bold = True
Cells(x, 4).Interior.Color = clryellow
Cells(x, 4).Font.Bold = True
End If
Next x
End With
For Each Worksheet In ActiveWorkbook.Worksheets
ActiveSheet.Calculate
Next Worksheet
end sub
You can .Select one or more objects (worksheets, cells, etc) into a collection but you can only .Activate one of them. Whatever is activated is always part of the selection, even if they are both the same single object. You do not need to both .Select and .Activate an object unless you are selecting more than one and require that one of them the the ActiveCell or ActiveSheet.
Essentially, a .Select method or .Activate method should be used to bring the worksheet or range object to the user's attention. It is not necessary to select or activate something in order to work with it (your value transfer speaks to that).
Here is a short rewrite of your routine that steers away from relying on .Select and .Activate to reference objects.
Sub summarizeRankings()
Dim lstA As Long, lstD As Long, clrYellow As Long, x As Long, ws As Worksheet
With ThisWorkbook
With .Worksheets("Rankings")
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count, 8)
.Cells.Sort Key1:=.Columns(8), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
.AutoFilter
End With
End With
Set ws = .Cells(1, 1).Parent
End With
With .Worksheets("Summary")
.Range("A8:A18").Value = ws.Range("A2:A12").Value
.Range("B8:B18").Value = ws.Range("E2:E12").Value
.Range("C8:C18").Value = ws.Range("G2:G12").Value
.Range("D8:D18").Value = ws.Range("H2:H12").Value
lstA = .Cells(Rows.Count, "A").End(xlUp).Row
lstD = .Cells(Rows.Count, "D").End(xlUp).Row
clrYellow = RGB(256, 256, 0)
For x = lstD To 8 Step -1
If (.Cells(x, "D").Value) >= 6 Then
.Cells(x, "A").EntireRow.Delete
ElseIf (.Cells(x, 4).Value) < 6 Then
.Cells(x, 1).Interior.Color = clrYellow
.Cells(x, 1).Font.Bold = True
.Cells(x, 4).Interior.Color = clrYellow
.Cells(x, 4).Font.Bold = True
End If
Next x
.Activate '<-last step brings the Summary worksheet to the front
End With
End With
Application.Calculate
End Sub
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
I have a column in excel, using vba I am trying to check if there is a duplicate entry in that column then delete duplicate and also main entry so there will be no value related to that entry anymore. What would be the way to do this ?
Input column=>
1
2
3
1
4
5
2
desired output column =>
3
4
5
Actually my entries are text but, I gave numerical example to make it clear
After answers my code became
Last_Row = ws1.Cells(Rows.Count, "G").End(xlUp).Row
Columns("G:H").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("G2", "G" & Last_Row) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("G1", "H" & Last_Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim i As Integer
i = 2
While (i < Last_Row + 1 And Not IsEmpty(Cells(i, 7).Value))
If Cells(i, 7) = Cells(i + 1, 7) Then
Range("G" & i + 1, "H" & i + 1).Delete Shift:=xlUp
Range("G" & i, "H" & i).Delete Shift:=xlUp
End If
If Not Cells(i, 7) = Cells(i + 1, 7) Then
i = i + 1
End If
Wend
This works. I haven't tried to optimise it or anything.
Dim v As Variant
Dim vOut As Variant
Dim ditch() As Integer
Dim i As Long, j As Long, n As Long
'Read input column into 2D array
v = Range("A1:A7").Value
'Mark which inputs to ditch (mark as 1 if duplicate, keep at 0 if not)
ReDim ditch(LBound(v, 1) To UBound(v, 1))
For i = LBound(v, 1) To UBound(v, 1)
For j = i + 1 To UBound(v)
If ditch(j) = 0 And v(j, 1) = v(i, 1) Then
ditch(i) = 1
ditch(j) = 1
End If
Next j
Next i
'How many non-duplicates are there?
n = UBound(v, 1) - LBound(v, 1) + 1 - WorksheetFunction.Sum(ditch)
'Put non-duplicates in new 2D array
ReDim vOut(1 To n, 1 To 1)
j = 0
For i = LBound(v, 1) To UBound(v, 1)
If ditch(i) = 0 Then
j = j + 1
vOut(j, 1) = v(i, 1)
End If
Next i
'Write array to sheet
Range("B1").Resize(n).Value = vOut
Not using VBA, a 'helper' column with =COUNTIF(A:A,A1) copied down to suit,if your data starts in Row1, should identify duplicates. Filter on the helper column and delete rows showing values greater than 1 may be suitable for you.
Create a macro Excel. Your Data should be in the first column and the worksheet to be called "Sheet1"
Columns("A:A").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Columns("A")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim i As Integer
Dim b As Boolean
i = 1
b = False
While Cells(i, 1) > 0
While Cells(i, 1) = Cells(i + 1, 1)
Rows(i + 1).Delete
b = True
Wend
If b = True Then
Rows(i).Delete
b = False
i = i - 1
End If
i = i + 1
Wend
In Excel 2007
click the "Data" Tab in the ribbon
Highlight your selection
click "Remove Duplicates"