I have below piece of code to remove duplicates from a sheet by looking into two columns (column 3 & 5).
lRow = .Cells(Rows.Count, "A").End(xlUp).Row
'.Range("A1:BR" & lRow).RemoveDuplicates Columns:=Array(3, 5), Header:=xlYes
.Range("$A$1:$BR$" & lRow).RemoveDuplicates Columns:=Array(3, 5), Header:=xlYes
It works fine in Windows but unfortunately not on Mac.
Can anybody please suggest me what do I need to change here?
This piece of code will create a list of unique values and copy into another cell. So create unique list.
You have to specify where your list starts, and where you want to copy to. You can do this by changing the fromCell and toCell variables. I hope this helps.
Sub uniqueList()
fromCell = "A1"
toCell = "B1"
fromColumn = Mid(fromCell, 1, 1) 'This will resolve to A
toColumn = Mid(toCell, 1, 1) 'This will resolve to B
fromRow = Mid(fromCell, 2) 'This will resolve to 1
toRow = Mid(toCell, 2) 'This will resolve to 1
Dim cl As Range, UniqueValues As New Collection, uValue As Variant
Application.Volatile
numRows = Range(fromCell).End(xlDown).Row
On Error Resume Next
For Each cl In Range(fromCell & ":" & fromColumn & numRows)
UniqueValues.Add cl.Value, CStr(cl.Value)
Next cl
y = toRow - 1
For Each uValue In UniqueValues
y = y + 1
Range(toColumn & y) = uValue
Next uValue
End Sub
I think the answers to this are dated. I'm updating, in case someone else searches.
.removeduplicates works in Excel in mac. It should just be whatever your selection is and then .removeduplicates.
so this...
Range().RemoveDuplicates
Related
Some background: Each month I build a pivot table that has approx 30 or so business units (along the y axis) - lets call them groups. Each group has a number of GL accounts that change month to month. For example, Group 14 might have 10 GL accounts one month than the next have only 3. For each group, we need the summation of the totals for the GL accounts (that start with PL203000 & PL211010) for each group. Before we had to total these GL accounts for each group by hand. This has been solved with the code I have displayed below.
The code works perfectly when each group has more than one GL account (See pic 1)
The problem I am facing is when there is only one GL account, the code doesn't sum the correct amounts (see 2nd pic).
When digging into my code, you can see that it is summing the incorrect sections since i have a Rows.Count.End(xlUp) establishing the range. If there is only one GL account, it skips to the next section thereby establishing an incorrect formula
Perhaps my code needs to be completely revamped in order to account for groups where there is only one GL account to sum? If so, what sort of if statement can i code where it ignores groups that have only one GL account?
If not, than is the solution to have VBA count the range and if it is less than 3, ignore group and move on to the next?
'this section spits out the values needed to sum
For i = nRowMax To 4 Step -1
If Left(Cells(i, 1), 8) = "PL211010" Or Left(Cells(i, 1), 8) = "PL203000"
Then
Cells(i, 4).Copy
Cells(i, 5).PasteSpecial xlPasteValues
Range(Cells(i, 1), Cells(i, 4)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next i
Application.CutCopyMode = False
'this section uses the values the first section specified to write the sum formula
'i believe the macro uses this section of code to write the first formula and the next section of code writes the formulas for the rest of the groups
Dim firstRow As Variant
Dim finalRow As Variant
finalRow = Range("E" & Rows.Count).End(xlUp).Row
firstRow = Cells(finalRow, 5).End(xlUp).Row
If IsNumeric(Cells(finalRow + 1, 5)) Then
Cells(firstRow, 6).Formula = "=SUM(D" & firstRow & ":D" & finalRow & ")"
End If
'this section goes through the whole sheet to sum each group
For y = firstRow To 5 Step -1
finalRow = Cells(y, 5).End(xlUp).Row
firstRow = Cells(finalRow, 5).End(xlUp).Row
If firstRow < 5 Then firstRow = 5
If IsNumeric(Cells(finalRow + 1, 5)) Then
Cells(firstRow, 6).Formula = "=SUM(D" & firstRow & ":D" & finalRow &")"
End If
y = firstRow
'If firstRow = 5 Then Exit Sub
Next y
If your dataset is an accurate enough example, you can scan through your business units and pick out only what you need. I have some example code here that will build up your sum range by using the Union function and applying that to the SUM formula when the entire business unit has been scanned. Of course, this is only an example that fits the data shown. You'll have to expand it to fit situations that are not visible to me.
To simplify the logic, I've separated the code into a function that will start scanning rows for a business unit and will stop when it reaches the end of the business unit -- the test I'm using for detecting the start of the next BU is a line that does not start with "PL". This may or may not be correct for all your data.
Because this code is checking each line and accumulating the sum range using the Union, if you only have one cell, you'll still get a formula that says =SUM($D$30) but it works.
Option Explicit
Sub test()
Dim dataArea As Range
Set dataArea = ActiveSheet.Range("A1")
Do While Not IsEmpty(dataArea.Cells(1, 1))
Set dataArea = AddSums(dataArea)
Loop
End Sub
Private Function AddSums(ByRef businessUnitStart As Range) As Range
'--- loops through cells following the 'Start' range given,
' and accumulates the range of accounts to summarize
' RETURNS the start of the next business unit range
Dim accountRow As Range
Dim account As String
Set accountRow = businessUnitStart.Offset(1, 0)
Dim sumArea As Range
Do While Left$(accountRow.Cells(1, 1).Value2, 2) = "PL"
account = accountRow.Cells(1, 1).Value2
If (Left$(account, 8) = "PL211010") Or (Left$(account, 8) = "PL203000") Then
'--- add this account to the sum formula
If sumArea Is Nothing Then
Set sumArea = accountRow.Cells(1, 4)
Else
Set sumArea = Union(sumArea, accountRow.Cells(1, 4))
End If
End If
Set accountRow = accountRow.Offset(1, 0)
Loop
If Not sumArea Is Nothing Then
Dim accountSum As Range
Set accountSum = businessUnitStart.Offset(1, 6)
accountSum.Formula = "=SUM(" & sumArea.Address & ")"
End If
Set AddSums = accountRow
End Function
At work I have a repetitive task of going through a list of account activity and changes where I have to delete blank spaces and lines that are not necessary for the maintenance I perform. For 80% of the these I am able to work a for each loop that is pretty inelegant but effective.
Example:
For Each c In ActiveSheet.UsedRange
If InStr(1, c.Value, SubString7) = 1 Then ' find earn lines and remove
c.EntireRow.Offset(1).Delete
c.EntireRow.Clear
c.EntireRow.Offset(-1).Delete
End If
Next
The substring is the descriptive title line for each type of transaction. The one I am having trouble with is variable, while the others are not. It can be 9 lines long or 6 lines long, and could also be positive or negative but each possibility comes with the same title line.
Based on everything I could find to try to figure it out, I need to use a loop, moving from bottom to top. I cannot get it to trigger with either InStr, nor left/right.
This is a cut down version of what I am trying now:
lr = Range("A" & Rows.Count).End(xlUp).Row
For rowcounter = lr To 0 Step -1
If VBA.Strings.Left(Cells(rowcounter).Value, 11) Like "Earn Manual" Then
If VBA.Strings.Left(Cells(rowcounter + 5).Value, 1) = "-" Then
If VBA.Strings.Left(Cells(rowcounter + 6).Value, 3) = "AVG" Then
Cells(rowcounter).EntireRow.Offset(5).Delete 'this, several more times with different offsets for the required lines
Else
Cells(rowcounter).EntireRow.Offset(5).Delete 'different ones, finalizing removals on the negative value items
End if
Else
If VBA.Strings.Left(Cells(rowcounter + 6).Value, 3) = "AVG" Then
Cells(rowcounter).EntireRow.Offset(5).Delete 'again, but with different offsets
Else 'There is one line for these that I have to split into two lines, not sure if this will even work as I cannot get it to trigger
Cells(rowcounter).EntireRow.Offset(8).Delete
Cells(rowcounter).EntireRow.Offset(7).Delete
Cells(rowcounter + 4).Value = VBA.Strings.Right(Cells(rowcounter + 3).Value, 25)
Cells(rowcounter + 3).Value = VBA.Strings.Left(Cells(rowcounter + 3).Value, 13)
End if
End If
End If
Next Rowcounter
I had originally had that first If line as:
If InStr(1, Cells(rowcounter).Value, SubString8) = 1 Then
I tried switching to Left() and Like but still no dice.
Attempting to provide sample of input/output
sample data:
Goal output from column A:
Retained Data
Update again, new and improved code that is still failing:
Next
For i = 1 To ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
If ws.Range("A" & i) Like "Earn Manual*" Then
If ws.c("A" & i + 5) Like "-*" Then
If ws.c("A" & i + 6) Like "Avg*" Then
Set Deleteme = c.Range("A" & i, "A" & i + 8) ' shows AVG, negative value
Else
Set Deleteme = c.Range("A" & i, "A" & i + 5) ' no AVG, negative value
End If
Else
If ws.c("A" & i + 6) Like "Avg*" Then
Set Deleteme = c.Range("A" & i, "A" & i + 3)
Set Deleteme = c.Range("A" & i + 5)
Else
Set Deleteme = c.Range("A" & i, "A" & i + 3)
Set Deleteme = c.Range("A" & i + 5)
End If
End If
Else
Set Deleteme = Union(Deleteme, ws.Range("A" & i))
End If
Next A
There is no way that I can get this 100% correct because it was based of the OP's new and improve code, which has some flaws in its logic. My goal was to simply the overall syntax to make it easier to get right.
The problem with deletion with offset values is that the values move on you. My solution is to Union all rows to be deleted and delete them then after the loop is done. This is not only more efficient but it allows us to loop from top to bottom. This makes the code it much easier to follow.
When Union ranges in this way, you must first test to see if the target range to be deleted is Nothing. If the target range is Nothing, we Set it to the new range else we Union the two ranges. I wrote a subroutine UnionRange(), so that we would not have to repeat this process each time we needed to do a Union.
With blocks, Range.Offset() and Range.Resize() were used to simply the syntax. I feel like this is cleaner than concatenating addresses inside of a range (e.g. Range("A" & i + 5) and Range("A" & i, "A" & i + 8)).
Sub CleanUp()
With ThisWorkbook.Worksheets("Sheet1")
Dim r As Long
Dim rUnion As Range
For r = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
With .Cells(r, 1)
If .Value = "" Then
UnionRange rUnion, .Offset(0)
ElseIf .Value Like "Earn Manual*" Then
If .Offset(6).Value Like "Avg*" Then ' shows AVG, negative value
UnionRange rUnion, .Offset(8)
Else ' no AVG, negative value
UnionRange rUnion, .Offset(5)
End If
Else
'This can't be right
If .Offset(6).Value Like "Avg*" Then 'If Like "Avg*" Then Delete These Cells
UnionRange rUnion, .Resize(3)
UnionRange rUnion, .Offset(5)
Else 'Hell If Not Like "Avg*" Then Delete The Same Cells Anyway
UnionRange rUnion, .Resize(3)
UnionRange rUnion, .Offset(5)
End If
End If
End With
Next
End With
If Not rUnion Is Nothing Then
Application.ScreenUpdating = False
rUnion.EntireRow.Delete
End If
End Sub
Sub UnionRange(ByRef rUnion As Range, ByRef Cell As Range)
If rUnion Is Nothing Then
Set rUnion = Cell
Else
Set rUnion = Union(rUnion, Cell)
End If
End Sub
I have a data set with Names and Addresses in an Excel file in following format.
Name1
134/47/1,
adrs1, adr2, country
Name2
adrs1, adrs2, country
Name3
107/c,
adrs3, adrs3, country
etc…
I want to split these data into multiple rows in following format
Name1
134/47/1,
adrs1,
adrs2,
country
Name2
No 134/63,
adrs1,
adrs2,
country
etc…
I tried following but it worked for one row cell only.
Sub tst()
Dim X As Variant
X = Split(Range("A1").Value, ",")
Range("A1").Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End Sub
The following macro might help you. You would have to select the very last cell in your table containing a multipart address. When you start the macro it will then work its way up to the top and insert address lines where needed (only in the current column) and then exit.
Option Base 1
Sub trnsfrm()
Dim i%, n%, ret(3, 1)
Set r = Selection
Do
a = Split(r, ",")
ret(1, 1) = Trim(a(0))
ret(2, 1) = Trim(a(1))
ret(3, 1) = Trim(a(2))
r.Range([a2], [a3]).Insert Shift:=xlDown
r.Range([a1], [a3]) = ret
If r.Row <= 4 Then Exit Do
Set r = r.Offset(-4)
Loop
End Sub
If you want to insert lines across the whole table you should replace the line (10)
r.Range([a2], [a3]).Insert Shift:=xlDown
by
r.Range([a2], [a3]).EntireRow.Insert Shift:=xlDown
Assumptions / Warning
Since the macro will actually change your current table and 'undo' does not work with macros you should definitely save everything before you try it.
The macro assumes that each address block consists of exactly 4 lines. If there are fewer or more lines to an address the maro will get out of sync and will very likely output garbage or halt.
I'm not sure whether your sample data had trailing commas on single values as a typo or if that is what accurately represents your data but that should be accounted for. A rogue comma as a suffix will create an extra element to the variant array thereby throwing off dimensions created by referencing the UBound function.
Sub split_from_below_space()
Dim rw As Long, v As Long, vVALs As Variant
With Worksheets("Sheet1") 'set this worksheet reference properly!
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
.Cells(rw, 1) = Trim(.Cells(rw, 1).Value2)
If CBool(InStr(1, .Cells(rw, 1).Value2, Chr(44) & Chr(32))) Then
vVALs = Split(.Cells(rw, 1).Value2, Chr(44) & Chr(32))
.Cells(rw + 1, 1).Resize(UBound(vVALs), 1).EntireRow.Insert
.Cells(rw, 1).Resize(UBound(vVALs) + 1, 1) = _
Application.Transpose(vVALs)
For v = UBound(vVALs) - 1 To LBound(vVALs) Step -1
.Cells(rw, 1).Offset(v, 0) = _
Trim(.Cells(rw, 1).Offset(v, 0).Value2) & Chr(44)
Next v
End If
Next rw
End With
End Sub
You will need to insert rows to accommodate the data and that method is almost always (as in this case) better performed by working from the bottom to the top.
this is my first time using the site, so forgive me for any inept explaining. I have a working macro to hide/unhide rows based on content of the rows, I just want it to be faster. Using a check box, when the box is checked, all rows with an "x" in column D get unhidden, those without an "x" get hidden. Same thing happens when it is unchecked, except it references column C, not D.
Right now, this code works. It's just a little slower than I'd like, since I'm sharing this with a bunch of people. Any ideas for how to speed it up? I'm pretty darn new to VB (the internet is astoundingly wise and a good teacher), but that doesn't matter. I already improved the code - before it selected each row, then referenced the column, and it was awful. Any ideas to speed it up (preferably without moving the screen) would be great.
Thanks so much folks,
DS
Sub NewLuxCheck()
Dim x As Integer
NumRows = Range("A42", "A398").Rows.Count
Range("A42").Select
If ActiveSheet.Shapes("checkbox2").OLEFormat.Object.Value = 1 Then
For x = 42 To NumRows + 41 Step 1
If Worksheets("Base").Range("D" & x).Value = "x" Then
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = False
Else
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = True
End If
Next
Else
For x = 42 To NumRows + 41 Step 1
If Worksheets("Base").Range("C" & x).Value = "x" Then
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = False
Else
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = True
End If
Next
End If
MsgBox ("Done")
End Sub
You could use array formula and let Excel to return array with row-numbers where 'x' value occures. It will be quicker but you'll have to reorganise your code and create separate functions etc.
Here example where array formula finds rows whre in column 'D' the cell has value 'x'. Then string of this row numbers is created in form of "A1,A5,A10" ...means 'x' was found in rows 1,5,10. And finally Range(rowsJoind).EntireRow.Hidden is used for all the rows to be hidden/un-hidden in one step.
For rows with value different then 'x' you'll have to use formula like '=IF({0}<>""x"", ROW({0}), -1)'.
Sub test()
Dim inputRange As Range
Dim lastRow As Long
Dim myFormula As String
Dim rowsJoined As String, i As Long
Dim result As Variant
With Worksheets("Base")
lastRow = .Range("D" & .Rows.Count).End(xlUp).Row
Set inputRange = .Columns("D").Resize(lastRow)
Application.ReferenceStyle = xlR1C1
myFormula = "=IF({0}=""x"", ROW({0}), -1)"
myFormula = VBA.Strings.Replace(myFormula, "{0}", inputRange.Address(ReferenceStyle:=xlR1C1))
result = Application.Evaluate(myFormula)
result = Application.Transpose(result)
Application.ReferenceStyle = xlA1
For i = LBound(result) To UBound(result)
If (result(i) > -1) Then
rowsJoined = rowsJoined & "A" & result(i) & IIf(i < UBound(result), ",", "")
End If
Next i
.Range(rowsJoined).EntireRow.Hidden = False
End With
End Sub
I have a problem with my hyperlink in excel. Im trying to set a hyperlink from one sheet to another but the source and target cell needs to change every time in the loop. Basically i want to move data from one cell in GROUP 1 to another cell in GROUP 2 then set a hyperlink from GROUP 2 back to the same cell in GROUP 1. I have like 200 values so i want to do this in a loop. I just can´t figure out whats wrong whit my SubAddress!!
This is my code below.....
Thank you for any help.
Sub Transfer_and link()
Dim i As Integer
Dim LastRow1, As Long
LastRow1 = Sheets("GROUP 1").Cells(Rows.Count, "A").End(xlUp).Row
a = 14
For i = 5 To LastRow1 Step 2
Sheets("GROUP 2").Cells(a, 2) = Sheets("GROUP 1").Cells(i, 1)
Sheets("GROUP 2").Cells(a, 3) = Sheets("GROUP 1").Cells(i, 9)
Sheets("GROUP 2").Cells(a, 4) = Sheets("GROUP 1").Cells(i, 10)
Sheets("GROUP 1").Activate
Cells(i, 1).Select
Worksheets(2).Hyperlinks.Add Anchor:=Worksheets(2).Cells(a, 2), Address:="", _
SubAddress:=ActiveCell.Address
a = a + 1
Next i
ActiveCell.Address only returns the cell reference. You need to add the sheet reference too.
It'd be something like:
SubAddress:=ActiveCell.Worksheet.Name & "!" & ActiveCell.Address
If your sheet name may have a space like yours, it'd actually have to be this:
SubAddress:="'" & ActiveCell.Worksheet.Name & "'!" & ActiveCell.Address