I have the macro below runs (no errors) but no results are provided. I have an excel book where duplicates are sometimes found in column "E". Those identified as duplicates should be copied to sheet 2. I know my workbook has duplicates in column E, their just not being copied over.
Sub FilterAndCopy()
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range
Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Sheet2")
Application.ScreenUpdating = False
With wstSource
Set rngMyData = .Range("a1:R" & .Range("a" & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)
With helperRng
.FormulaR1C1 = "=if(countif(c1,RC1)>1,"""",1)"
.Value = .Value
If Evaluate("=COUNTBLANK(" & .Address & ")") > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(2, 1)
.ClearContents
End With
Application.ScreenUpdating = True
End Sub
Because of the cell notation you are using R1C1, your formula
.FormulaR1C1 = "=if(countif(c1,RC1)>1,"""",1)"
refers only to column A
If you want to change your formula to apply on column E, that would be
.FormulaR1C1 = "=if(countif(c5,RC5)>1,"""",1)"
I don't know if your dupplicates are on a single column basis or if should concatenate all your column to see if the entire row is a dupplicate. It might be more simple to apply a sql query connection on this. Pivot tables may also help. If you stick to vba, add additional line for each dupplicate formula and process it in the block of code that copy blank formula to the secondary sheet.
Related
Had no luck figuring out how to code this in VBA.
I have a list of names on ws2 starting in cell A5. The size of this list will change daily. I want to vlookup each item from data on ws1. Then would like paste the data as values into corresponding cell in column C.
Picture below is what ws2 looks like. That's the vlookup formula I would have used if done manually.
Could also consider xlookup if you think it's better. Lookup array would be column A on ws1, return array would be column E.
Hoping to keep the code as simple as possible since this is my first VBA project. Any comments/explanations would be much appreciated!
Thanks!
Tab names
If 'ws1' and 'ws2' are the tab names of the worksheets this should do it, note I've changed A:L to A:E in the formula as you aren't looking up anything past column E.
Sub Button1_Click()
Dim ws As Worksheet
Set ws = Sheets("ws2")
With ws.Range("C5:C" & ws.Range("A" & Rows.Count).End(xlUp).Row)
.Formula = "=VLOOKUP(A5, ws1!A:E,5,0)"
.Value = .Value
End With
End Sub
Variable names
If 'ws1' and 'ws2' are variable names referencing sheets then use this.
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
With ws2.Range("C5:C" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
.Formula = "=VLOOKUP(A5,'" & ws1.Name & "'!A:E,5,0)"
.Value = .Value
End With
End Sub
Codenames
Finally, if ws1 and ws2 are actually the codenames of the worksheets this should work.
Sub Button1_Click()
With ws2.Range("C5:C" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
.Formula = "=VLOOKUP(A5,'" & ws1.Name & "'!A:E,5,0)"
.Value = .Value
End With
End Sub
I have a workbook that is being updated regularly by third parties. Let's call each update WB1, WB2... The data in WB is formatted as a table in columns A:F, and there are approx. 2000 rows. There is one sheet of data. In my copy of WB, I called it "Master." In WB1, WB2..., it is "Indexes." Column A has a unique identifier for each row, and the rest of the data is text.
I'm adding notes next to each row, in columns G:H. I need to be able to merge the unique entries from WB 1 into my copy of WB, while preserving my notes in G:H, and the conditional formatting I added to WB. I want to use VBA, and I do not have Microsoft Access.
I found a partial solution here: Find Duplicate Values In Excel and Export Rows to another sheet using VBA
I made the following changes to the solution linked above:
Option Explicit
Sub MergeTables()
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range, _
unionRng As Range
Dim i As Long, iOld As Long
Set wstSource = Worksheets("Indexes")
Set wstOutput = Worksheets("Master")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With wstSource
Set rngMyData = .Range("A1:J" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
With rngMyData
Set helperRng = .Offset(, rngMyData.Columns.Count - 1).Resize(, 1)
Set unionRng = .Cells(3000, 3000) 'set a "helper" cell to be used with Union method, to prevent it from failing the first time
End With
With helperRng
.FormulaR1C1 = "=row()" 'mark rows with ad ascending number (its own row number)
.Value = .Value
End With
With rngMyData.Resize(, rngMyData.Columns.Count + 1) 'enclose "helper" column
i = .Rows(1).Row 'start loop from data first row
Do While i < .Rows(.Rows.Count).Row
iOld = i 'set current row as starting row
Do While .Cells(iOld + 1, 1) = .Cells(iOld, 1) 'loop till first cell with different value
iOld = iOld + 1
Loop
If iOld - i = 0 Then Set unionRng = Union(unionRng, .Cells(i, 1).Resize(iOld - i + 1)) 'if more than one cell found with "current" value, then add them to "UnionRng" range
i = iOld + 1
Loop
Intersect(unionRng, rngMyData).Range("A:F").Copy Destination:=wstOutput.Cells(1, 1) 'get rid of the "helper" cell via Intersect method
wstOutput.Columns(helperRng.Column).Clear 'delete "Helper" column pasted in wstOutput sheet
.Sort key1:=.Columns(6), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes ' sort data in wstSource back
End With
helperRng.Clear 'delete "helper" column, not needed anymore
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
This macro successfully adds in the new rows, but my notes in G:H do not line up with the original data anymore.
Can you please suggest alternative approaches, or revisions to this macro?
Thanks
Edit 1:
#dwirony I've attached three photos: A sample version of WB before using the macro, a sample of an updated WB1, and a sample version of WB after using the macro.
I want to find duplicates in two separate columns and extract only those that have duplicates in both of these columns to another worksheet. I want to compare these columns to themselves and find duplicates within the same column. Any advice about how to go about this.
One column contains currency and another contains text. I added apicture for clarification,but this is is what I have tried so far:
Sub match()
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range
Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Sheet2")
With wstSource
Set rngMyData = .Range("A1:AC" & .Range("T" & .Rows.Count) & .Range(Left("N", 4) & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)
With helperRng
.FormulaR1C1 = "=if(countif(C20,RC20)>1,"""",1)"
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(2, 1)
.ClearContents
End With
End Sub
I have an Excel sheet with names in column A and an amount in column B for sheet 1.
I have a another sheet that is sheet2 with names in A just like in sheet 1 and column B is blank.
How can I check sheet 1 A name to check with sheet2 A name, if they match then take amount next to that name on sheet1 and copy the amount into the cell next to the matching name on sheet2 next to the name? The names on sheet1 change daily.
I have tried this and get nothing.
Sub Macro1()
'
' Macro1 Macro
'
Dim RowIndex As Integer
Sheets("Sheet1").Select
RowIndex = Cells.Row
While DoOne(RowIndex)
RowIndex = RowIndex + 3
Wend
End Sub
Function DoOne(RowIndex As Integer) As Boolean
Dim Key
Dim Target
Dim Success
Success = False
If Not IsEmpty(Cells(RowIndex, 1).Value) Then
Key = Cells(RowIndex, 1).Value
Sheets("sheet2").Select
Set Target = Columns(2).Find(Key, LookIn:=xlValues)
If Not Target Is Nothing Then
Rows(Target.Row).Select
Selection.Copy
Sheets("Sheet1").Select
Rows(RowIndex + 1).Select
Selection.Insert Shift:=xlDown
Rows(RowIndex + 2).Select
Application.CutCopyMode = False
Success = True
End If
End If
DoOne = Success
End Function
Sheet 1:
A B
A One Preservation $16.00
A&D Recovery, Inc. $8,108.46
A&S Field Services, Inc. $4,941.56
A&T Jax Inc $1,842.48
Sheet 2:
A B - blank cell
A One Preservation - Calvin & Renee
A&D Recovery, Inc. - Drew & Adam
A&S Field Services, Inc. - Aaron
A&T Jax Inc - Tyson
This code uses an Index/Match solution to copy the matched B values from sheet1 from sheet2. The code will work with variable sheet names
blank cells are ignored
Non-matches on the second sheet are flagged as "no match".
The code removes the formulae from column B on the second sheet by updating with values only
Update: if you second sheet names are the same as sheet1, but have a " -some text" to the right, then use this updated part of the code
With rng1.Offset(0, 1)
.FormulaR1C1 = "=IF(RC[-1]<>"""",IF(NOT(ISERROR(MATCH(LEFT(RC[-1],FIND("" -"",RC[-1])-1),'" & ws1.Name & "'!C[-1],0))),INDEX('" & ws1.Name & "'!C,MATCH(LEFT(RC[-1],FIND("" -"",RC[-1])-1),'" & ws1.Name & "'!C[-1],0)),""no match""),"""")"
.Value = .Value
End With
original
Sub QuickUpdate()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
Set rng1 = ws2.Range(ws2.[a1], ws2.Cells(Rows.Count, "A").End(xlUp))
With rng1.Offset(0, 1)
.FormulaR1C1 = "=IF(RC[-1]<>"""",IF(NOT(ISNA(MATCH(RC[-1],'" & ws1.Name & "'!C[-1],0))),INDEX('" & ws1.Name & "'!C,MATCH(RC[-1],'" & ws1.Name & "'!C[-1],0)),""no match""),"""")"
.Value = .Value
End With
End Sub
Why not use the VLOOKUP function?
Sheet1 has your names in column A, and values in column B.
Sheet2 has your lookup names in column A, and in column B, you put:
=VLOOKUP(A1,Sheet1!$A$1:$B$n,2,FALSE)
Where 'n' is the number of rows in your Sheet1 table.
The only issue with this is it will put an #N/A if it can't find the name in Sheet1. There's likely a way to put in an alternate entry using a conditional.
I need to find out the first cell and the last cell of a vertically merged cell..
Let's say I merge Cells B2 down to B50.
How can I get in VBA the start cell(=B2) and the end cell(=B50)?
Sub MergedAreaStartAndEnd()
Dim rng As Range
Dim rngStart As Range
Dim rngEnd As Range
Set rng = Range("B2")
If rng.MergeCells Then
Set rng = rng.MergeArea
Set rngStart = rng.Cells(1, 1)
Set rngEnd = rng.Cells(rng.Rows.Count, rng.Columns.Count)
MsgBox "First Cell " & rngStart.Address & vbNewLine & "Last Cell " & rngEnd.Address
Else
MsgBox "Not merged area"
End If
End Sub
Below macro goes through all sheets in a workbook and finds merged cells, unmerge them and put original value to all merged cells.
This is frequently needed for DB applications, so I wanted to share with you.
Sub BirlesenHucreleriAyirDegerleriGeriYaz()
Dim Hucre As Range
Dim Aralik
Dim icerik
Dim mySheet As Worksheet
For Each mySheet In Worksheets
mySheet.Activate
MsgBox mySheet.Name & “ yapılacak…”
For Each Hucre In mySheet.UsedRange
If Hucre.MergeCells Then
Hucre.Orientation = xlHorizontal
Aralik = Hucre.MergeArea.Address
icerik = Hucre
Hucre.MergeCells = False
Range(Aralik) = icerik
End If
Next
MsgBox mySheet.Name & " Bitti!!"
Next mySheet
End Sub
Suppose you merged B2 down to B50.
Then, start cell address will be:
MsgBox Range("B2").MergeArea.Cells(1, 1).Address
End cell address will be:
With Range("B2").MergeArea
MsgBox .Cells(.Rows.Count, .Columns.Count).Address
End With
You can put address of any cell of merged area in place of B2 in above code.
Well, assuming you know the address of one of the cells in the merged range, you could just select the offset from that range and get the row/column:
Sub GetMergedRows()
Range("A7").Select 'this assumes you know at least one cell in a merged range.
ActiveCell.Offset(-1, 0).Select
iStartRow = ActiveCell.Row + 1
Range("A7").Select
ActiveCell.Offset(1, 0).Select
iEndRow = ActiveCell.Row - 1
MsgBox iStartRow & ":" & iEndRow
End Sub
The code above will throw errors if the offset row cannot be selected (i.e. if the merged rows are A1 through whatever) so you will want to add error handling that tells the code if it can't offset up, the top rows must be 1 and if it can't go down, the bottom row must be 65,536. This code is also just one dimensional so you might want to add the x-axis as well.
If you want the cell references as strings, you can use something like this, where Location, StartCell, and EndCell are string variables.
Location = Selection.Address(False, False)
Colon = InStr(Location, ":")
If Colon <> 0 Then
StartCell = Left(Location, Colon - 1)
EndCell = Mid(Location, Colon + 1)
End If
If you want to set them as ranges, you could add this, where StartRange and EndRange are Range objects.
set StartRange = Range(StartCell)
set EndRange = Range (EndCell)
If you intend to loop through the merged cells, try this.
Sub LoopThroughMergedArea()
Dim rng As Range, c As Range
Set rng = [F5]
For Each c In rng.MergeArea
'Your code goes here
Debug.Print c.Address'<-Sample code
Next c
End Sub