Search delete copy-N-paste to new sheet not working....

[andre30331]

Hello,

I have code that when I select column B the script looks through column B for duplicate values among unique numerical strings of data. When a duplicate is located the code should delete the entire row without scrambling or re-sorting the data set and copy the final result of the entire sheet inclusive of columns A:E to a new sheet.

1. The first issue I am having is instead of coping the final results and the data from columns A thru E onto the new sheet it only copies the value of column B to all other columns on the new sheet.Column B data rereated in cloumn A,C,D,& E
2. The second issues is I would simply like to run the code and it search through column B without having to actually select column B for the code to work.

Thanks in advance for helping.

Option Explicit


Sub List_Unique_Values()


Dim rSelection As Range
Dim ws As Worksheet
Dim vArray() As Long
Dim i As Long
Dim iColCount As Long


  
  If TypeName(Selection) <> "Range" Then
    MsgBox "Please select a range first.", vbOKOnly, "List Unique Values Macro"
    Exit Sub
  End If
  
  
  Set rSelection = Selection


 
  Set ws = Worksheets.Add
  
  
  rSelection.Copy
  
  With ws.Range("A:E")
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
    '.PasteSpecial xlPasteValuesAndNumberFormats
  End With
  


  iColCount = rSelection.Columns.Count
  ReDim vArray(1 To iColCount)
  For i = 1 To iColCount
    vArray(i) = i
  Next i
  
  'Remove duplicates
  ws.UsedRange.RemoveDuplicates Columns:=vArray(i - 1), Header:=xlGuess
  
  
  On Error Resume Next
    ws.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp
  On Error GoTo 0
  
  
  ws.Columns("A").AutoFit
  


  Application.CutCopyMode = False
    
End Sub

 

[Logit]

.
Try this :

Option Explicit


Sub DeleteDups()
     
    Dim x               As Long
    Dim LastRow         As Long
    Dim Cells           As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        LastRow = LastRow
    End With
 
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("B1:B" & x), Range("B" & x).Text) > 1 Then
            Range("B" & x).EntireRow.Delete
        End If
    Next x
    Application.ScreenUpdating = True
    
    CpyPaste
   
End Sub




Sub CpyPaste()
Dim lRow As Long
Dim sht As Worksheet
Set sht = ActiveSheet    'x.Sheets("SheetName")


Application.ScreenUpdating = False


lRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row


sht.Range("A1:E" & lRow).Copy
Sheet2.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False


Sheet1.Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[andre30331]

.
Try this :

Option Explicit


Sub DeleteDups()
     
    Dim x               As Long
    Dim LastRow         As Long
    Dim Cells           As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        LastRow = LastRow
    End With
 
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("B1:B" & x), Range("B" & x).Text) > 1 Then
            Range("B" & x).EntireRow.Delete
        End If
    Next x
    Application.ScreenUpdating = True
    
    CpyPaste
   
End Sub




Sub CpyPaste()
Dim lRow As Long
Dim sht As Worksheet
Set sht = ActiveSheet    'x.Sheets("SheetName")


Application.ScreenUpdating = False


lRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row


sht.Range("A1:E" & lRow).Copy
Sheet2.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False


Sheet1.Range("A1").Select
Application.ScreenUpdating = True
End Sub

Thanks Logit. The remove duplicates code seems to work fine but the copy/paste code should create a new sheet to place the data when the code is run. Currently it shows an error if the workbook previously had a sheet2 that may have been deleted. If i create a new sheet2 before running the code the new sheet2 is actually sheet3(sheet2) in visual basic.

 

[Logit]

.
Change the CpyPaste macro to this :

Sub CpyPaste()
Dim lRow As Long
Dim sht As Worksheet
Set sht = ActiveSheet


Application.ScreenUpdating = False


With ThisWorkbook
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Data Update"
End With




lRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row


sht.Range("A1:E" & lRow).Copy
Sheets("Data Update").Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False


Sheets("Data Update").Range("A1").Select
'Sheet1.Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[andre30331]

Thanks Logit. The remove duplicates code seems to work fine but the copy/paste code should create a new sheet to place the data when the code is run. Currently it shows an error if the workbook previously had a sheet2 that may have been deleted. If i create a new sheet2 before running the code the new sheet2 is actually sheet3(sheet2) in visual basic.

That worked.... Thank you

 

[Logit]

You are welcome.

Glad to help.