Solved: Range selection and other questions

[Pam in TX]

The more I try to do this, the more I realize how little I know...... Here is my latest request for assistance....

In my workbook on sheet1 I have a varying number of rows of information.... I have several things that I need to happen...

1. We are having trouble with a range issue...... We need to select all rows if there is any information contained in columns A:U

2. In populated rows, if all columns between U:CK are totally blank, remove the row and place that rows information on a new sheet called ABSENT along with a copy the information from header rows 1 and 2

3: In populated rows, if column C contains a duplicate number, remove the row and place that rows information on a new sheet called DUPLICATE IDs along with a copy the information from header rows 1 and 2, if not do nothing

These actions are repeated MANY MANY times daily in our office.... anad will be incorporated into macros we currently have........... We :bow: :bow: and thank you for the assistance....

[lucas]

1. We are having trouble with a range issue...... We need to select all rows if there is any information contained in columns A:U

2. In populated rows, if all columns between U:CK are totally blank, remove the row and place that rows information on a new sheet called ABSENT along with a copy the information from header rows 1 and 2

Let's try to solve the first problem....
Let's try to clear up some questions I have from reading your post ok..
In question 1 you wish to "select" the range if ther is data from col A to U

Is that so you can do the operations in question 2 & 3? or is there a reason other than that to select the range?

Then you wish to move rows with no data from U to CK on each row to another sheet...

Why do you need to move the header rows with each operation....could you not already have a duplicate set of header rows on the sheet your copying to..?

[Pam in TX]

Let's try to solve the first problem....
Let's try to clear up some questions I have from reading your post ok..
In question 1 you wish to "select" the range if ther is data from col A to U

Is that so you can do the operations in question 2 & 3? or is there a reason other than that to select the range?

Then you wish to move rows with no data from U to CK on each row to another sheet...

Why do you need to move the header rows with each operation....could you not already have a duplicate set of header rows on the sheet your copying to..?

In this case range from A:U is related to questions 2 and 3 and other parts of the macro currently in place.... Column U is where the answers to a test begin and can go through CK (depending on the test length).... Columns A:T contain individual student information.... Row 1 is the header row and Row 2 is the answer key, which shows the total correct in Column CL

This whole operation begins with importing a text file into a new workbook onto sheet 1...... and is the beginning of a whole process.......

Thanks for the help......

[mdmackillop]

Can you post a sample workbook to save us having to replicate one?

[Pam in TX]

Can you post a sample workbook to save us having to replicate one?

Sure, not a problem.....

[Aussiebear]

Don't quote this yet PAM but I started with DRJ's code

Option Explicit

Sub DeleteDups()

Dim x As Long
Dim LastRow As Long

LastRow = Range("A65536").End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
Range("A" & x).EntireRow.Delete
End If
Next x

End Sub

and tried to modify it to the following

Option Explicit
Sub DeleteDups()

Dim x As Long
Dim LastRow As Long
Dim LRow As Long
Dim cRow As Long
Dim Tgt As Target
LastRow = Range("C65536").End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("C3:C" & x), Range("C" & x).Text) > 1 Then

' Copy data to "Duplicates" and clear data from "Main".

LRow = Sheets("Duplicates").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
With ActiveSheet
Range(.Cells(Tgt.Row, 1), .Cells(Tgt.Row, 51)).Copy

With Sheets("Duplicates")
.Range(.Cells(LRow, 1), .Cells(LRow, 51)).PasteSpecial xlValues
End With
Application.CutCopyMode = False
cRow = Target.Row
.EntireRow.Delete
End With
End If
Next x

End Sub

Which is modified from some code that MD wrote for me, but it says that I haven't defined "Target". Target is cRow (well I want it to be this) so will try some more.

[Aussiebear]

Still not working properly, so I'll await the experts to clean this up

Option Explicit

Sub DeleteDups()

Dim X As Long
Dim Lastrow As Long
Dim lRow As Long
Dim cRow As Long
Dim Target As Range

Lastrow = Range("C65536").End(xlUp).Row
For X = Lastrow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("C3:C" & X), Range("C" & X).Text) > 1 Then

' Copy data to "DuplicateIDs" and clear data from "Main".

lRow = Sheets("DuplicateIDs").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
With ActiveSheet
Range(.Cells(Target.Row, 1), .Cells(Target.Row, 69)).Copy

With Sheets("DuplicateIDs")
.Range(.Cells(lRow, 1), .Cells(lRow, 69)).PasteSpecial xlValues
End With
Application.CutCopyMode = False
cRow = Target.Row
.Range("A" & cRow & ":CK" & cRow).EntireRow.Delete
End With
End If
Next X

End Sub

Sub Absents()

Dim X As Long
Dim Lastrow As Long
Dim lRow As Long
Dim cRow As Long
Dim Target As Range

Lastrow = Range("C65536").End(xlUp).Row
For X = Lastrow To 1 Step -1
If Target.Columns("U:CK") = "" Then
' Copy data to "Absent" and clear data from "Main".

lRow = Sheets("Absent").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
With ActiveSheet
Range(.Cells(Target.Row, 1), .Cells(Target.Row, 69)).Copy

With Sheets("DuplicateIDs")
.Range(.Cells(lRow, 1), .Cells(lRow, 69)).PasteSpecial xlValues
End With
Application.CutCopyMode = False
cRow = Target.Row
.Range("A" & cRow & ":CK" & cRow).EntireRow.Delete
End With
End If
Next X


End Sub

[Aussiebear]

one last effort... ( Many thanks to XLD for his corrections)


Sub ProcessData()
Dim X As Long
Dim Lastrow As Long
Dim iDupRow As Long
Dim iAbsent As Long
Dim sh As Worksheet

Set sh = ActiveSheet
Lastrow = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "ABSENT"
sh.Rows("1:2").Copy Worksheets("ABSENT").Range("A1")
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "DUPLICATE IDS"
sh.Rows("1:2").Copy Worksheets("DUPLICATE IDS").Range("A1")
For X = Lastrow To 1 Step -1
If Application.Count(sh.Range(sh.Cells(X, "U"), sh.Cells(X, "CK"))) = 0 Then

With Worksheets("ABSENT")
iAbsent = .Cells(.Rows.Count, "C").End(xlUp).Row
sh.Rows(X).Copy .Range("A" & iAbsent + 1)
sh.Rows(X).Delete
End With

ElseIf Application.CountIf(sh.Range("C3:C" & X), sh.Range("C" & X).Text) > 1 Then

With Worksheets("DUPLICATE IDS")
iDupRow = .Cells(.Rows.Count, "C").End(xlUp).Row
sh.Rows(X).Copy .Range("A" & iDupRow + 1)
sh.Rows(X).Delete
End With

End If
Next X

End Sub

[Pam in TX]

Aussie,

Thanks for the assistance.... and to XLD also....

These are almost working perfectly.....

Regarding DUPS, It is removing the second item only.... How difficult would it be to pick up both IDs and move them to the DUPS sheet?

ABSENTS: For some reason, it is removing my header row off the original sheet and creating it twice (top and bottom) on the absent sheet...

I am constantly amazed at the wealth of knowledge on these boards....

Thanks for the continued patience with my ignorance.... I am still trying to learn....

[mdmackillop]

Nice work Ted. :clap::clap::clap:
Option Explicit

Sub ProcessData()
Dim X As Long
Dim Lastrow As Long
Dim iDupRow As Long
Dim iAbsent As Long
Dim sh As Worksheet
Dim c As Range
Dim Found As Range
Dim FirstAddress As String

Set sh = ActiveSheet
Lastrow = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "ABSENT"
sh.Rows("1:2").Copy Worksheets("ABSENT").Range("A1")
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "DUPLICATE IDS"
sh.Rows("1:2").Copy Worksheets("DUPLICATE IDS").Range("A1")
For X = Lastrow To 1 Step -1
If Application.Count(sh.Range(sh.Cells(X, "U"), sh.Cells(X, "CK"))) = 0 Then

With Worksheets("ABSENT")
iAbsent = .Cells(.Rows.Count, "C").End(xlUp).Row
If X > 2 Then
sh.Rows(X).Copy .Range("A" & iAbsent + 1)
sh.Rows(X).Delete
End If
End With

ElseIf Application.CountIf(sh.Range("C3:C" & X), sh.Range("C" & X).Text) > 1 Then

With sh
Set c = .Columns(3).Find(.Range("C" & X), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
If Found Is Nothing Then
Set Found = c
Else
Set Found = Union(Found, c)
End If

Set c = .Columns(3).FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With

With Worksheets("DUPLICATE IDS")
iDupRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Found.EntireRow.Copy .Range("A" & iDupRow + 1)
Found.EntireRow.Delete
End With
End If
Next X

End Sub

[Pam in TX]

Thanks everyone....

mdmackillop: When I try the one you provided I end up with an error "Method of 'union' object_'global" failed.... It tells me the error is on the line
Set Found = Union(Found, c)

One more thing, if there are blanks in the id's those are not to be considered dups.... Sorry just thought of that one....

You guys have been wonderful for helping.... I can't begin to tell you how much this will help out.... thanks again....

[rbrhodes]

Hi Pam,

Here's a hybrid of Aus & Md's approach with a pinch of my stuff thrown in (killing old sheets for example). I figure if you're creating the sheets on the fly you're not archiving so kill the old ones first...

Also I choose to run two loops:
First one moves ALL instances of the dupe except BLANK id's.

Second loop does absents. I logic if it's a dupe and an absent it goes dupe first.



I zipped it as it's a little large, hope thats OK.

Cheers,

dr

[Pam in TX]

When I ran it I got all the dups and the absents on the dups sheet..... By moving the absent loop to be done first, that took care of it..... It works perfect.....

Thank you again so very much...... You are awesome......

[rbrhodes]

Hi Pam,

Can't believe I made an error... <GRIN>

Glad it works for you!

Cheers,

dr

[Pam in TX]

Hi Pam,

Can't believe I made an error... <GRIN>

Glad it works for you!

Cheers,

dr

No, the amazing part is that I could figure out how to make it work.....

Thanks again.....

[Aussiebear]

Well actually, my initial intention was not to create sheets on the fly. Since I figure you will be entering data from time to time. However my english friend (who lays about in the midday sun punning madly), created it in his responce.

[Pam in TX]

Aussiebear, :rotlaugh: :rotlaugh: :thumb

rbrhodes and Aussie,

Ok gang, I ran into a problem when I brought it to work..... :help

It works on the original sample file, that I posted and that you worked from..... but when I use the macro (whether copying it to new workbook or using it from the original file) with new data it doesn't pull over the first duplicate record it finds.... So if I have 2 sets of dupes, the duplicate ID sheet will only have 3 rows..... I don't understand............ why it would work with the original information only.....:bug: I have been working with this all morning........ Originally I thought the problem was when I brought it over to include it with the rest of the clean-up process.... But that wasn't it.......:help

I am attaching a sample.........

[rbrhodes]

Hi Pam,

Something I missed.

I used the error value in the Do/Loop to check if a dupe was found. If no error then dupe was found, if is error then wasn't found.

The problem is that at the beginning of the sub I put in two lines to delete any old sheets. If they don't exist that throws an error of course. I forgot to clear this error before the Do/Loop!

This version fixes that.

Cheers,

dr

[Pam in TX]

Hi Pam,

Something I missed.

I used the error value in the Do/Loop to check if a dupe was found. If no error then dupe was found, if is error then wasn't found.

The problem is that at the beginning of the sub I put in two lines to delete any old sheets. If they don't exist that throws an error of course. I forgot to clear this error before the Do/Loop!

This version fixes that.

Cheers,

dr

Thanks for the update......... will give it a whirl tomorrow at the office....