find/delete data on different tabs

Peruanos72 · Nov 5, 2009

Hello all,

I have a tab named "untitled" and a tab named "bluecard_homeplanaid".
I have data in tab "untitled" column "B". They're numbers such as
200906180333.
I need code to that takes the number in the first cell "B1" in tab
"untitled" and searches column "B" in tab "bluecard_homeplanaid". If found,
then that row in tab "bluecard_homeplanaid" would be deleted. This process
repeats for all of the numbers in column "B" in tab "untitled.

Note: The amount of data in column "B" , tab "untitled" changes daily.

thanks in advance!!!

john · Nov 5, 2009

see if this does what you want. Suggest that you make back-up of your data
before testing.

Sub DeleteData()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim StartRow As Long
Dim EndRow As Long
Dim Lr As Long
Dim FoundCell As Range
Dim Search As String
Dim icount As Long

With ThisWorkbook

Set ws1 = .Worksheets("untitled")
Set ws2 = .Worksheets("bluecard_homeplanaid")

End With

'assume you have a header in row 1
StartRow = 2

icount = 0

With ws1

EndRow = .Cells(.Rows.Count, "B").End(xlUp).Row

For Lr = StartRow To EndRow

Search = .Cells(Lr, 2).Value

If Search <> "" Then

Set FoundCell = ws2.Columns(2).Find(Search, _
After:=ws2.Cells(1, 2), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

If FoundCell Is Nothing = False Then

FoundCell.EntireRow.Delete

icount = icount + 1

End If

End If

Next

End With

msg = MsgBox(icount & " Records Deleted", vbInformation, "Delete Data")

End Sub

Peruanos72 · Nov 6, 2009

Hi John,

I'm getting a "Subscript out of range" error when the code hits
Set ws1 = .Worksheets("untitled")

i moved that worksheet so it's the first worksheet but the error still
comes up. I only have the two worksheets in the workbook.

Thoughts??

john · Nov 6, 2009

It means it can't find a worksheet with that name - I copied the names from
your post - check the spellings & try again.

Peruanos72 · Nov 6, 2009

The spelling was correct. my code copies my tabs to a new workbook so the
master file is not touched and my code runs in the new workbook from the
master file. it appears your code doesn't work in the new book that's created
but it does work if done in the master file.

Is there a way to run your code in my new workbook?

john · Nov 6, 2009

did not see that requirement in your original post.
Yes is the short answer but it would help if you post all the code you are
using.

I am about to leave office & out for evening will respond asap

Peruanos72 · Nov 6, 2009

Here's my code. It's in two parts b/c it's lengthy. And thanks again for your
help.

Sub update()
'
' update Macro
' Macro recorded 3/30/2009 by rblakeman
'

'

'Begin update

Sheets(Array("bluecard_homeplanaid", "bzv", "kpx", "uco", "hvu",
"generic", "bnl", "eca", "fus", "och", "rkk", "hbg", "lmp", "nfh")).Copy
Sheets("bluecard_homeplanaid").Select
ActiveSheet.Unprotect
Range("L1").Clear

' BZV

Range("A4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A4").Select

Sheets("bzv").Select

'Import

Range("B2").Select
Dim ans1 As Long
ans1 = MsgBox("Import Data for ""BZV""?", vbYesNo + vbQuestion +
vbDefaultButton2)

If ans1 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "BZV"

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("kpx").Select

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

' END BZV

'IMPORT KPX

Range("B2").Select

Dim ans2 As Long
ans2 = MsgBox("Import Data for ""KPX""?", vbYesNo + vbQuestion +
vbDefaultButton2)

If ans2 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "KPX"

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("uco").Select

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

' END KPX

'IMPORT UCO

Range("B2").Select

Dim ans3 As Long
ans3 = MsgBox("Import Data for ""UCO""?", vbYesNo + vbQuestion +
vbDefaultButton2)

If ans3 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "UCO"

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("hvu").Select

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

'END UCO

'IMPORT HVU

Range("B2").Select

Dim ans4 As Long
ans4 = MsgBox("Import Data for ""HVU""?", vbYesNo + vbQuestion +
vbDefaultButton2)

If ans4 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "HVU"

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("generic").Select

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

'END HVU

'IMPORT GENERIC

Range("B2").Select

Dim ans5 As Long
ans5 = MsgBox("Import Data for ""Generic""?", vbYesNo + vbQuestion +
vbDefaultButton2)

If ans5 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "GENERIC"

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("bnl").Select

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

' END GENERIC

'IMPORT BNL

Range("B2").Select

Dim ans6 As Long
ans6 = MsgBox("Import Data for ""BNL""?", vbYesNo + vbQuestion +
vbDefaultButton2)

If ans6 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "BNL"

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("eca").Select ' IF A NEW TAB IS CREATED THEN CHANGE THE SHEET
NAME TO RELFECT NEW TAB

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

' End BNL

'IMPORT ECA

Range("B2").Select

Dim ans7 As Long
ans7 = MsgBox("Import Data for ""ECA""?", vbYesNo + vbQuestion +
vbDefaultButton2)
' ENER NEW GROUP ACRONYM ABOVE

If ans7 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "ECA" ' ENTER NEW GROUP ACRONYM

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("fus").Select ' IF A NEW TAB IS CREATED THEN CHANGE THE SHEET
NAME TO RELFECT NEW TAB

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

' End ECA

'IMPORT FUS

Range("B2").Select

Dim ans8 As Long
ans8 = MsgBox("Import Data for ""FUS""?", vbYesNo + vbQuestion +
vbDefaultButton2)
' ENER NEW GROUP ACRONYM ABOVE

If ans8 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "FUS" ' ENTER NEW GROUP ACRONYM

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("och").Select ' IF A NEW TAB IS CREATED THEN CHANGE THE SHEET
NAME TO RELFECT NEW TAB

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

' End FUS

'Import OCH

Range("B2").Select

Dim ans9 As Long
ans9 = MsgBox("Import Data for ""OCH""?", vbYesNo + vbQuestion +
vbDefaultButton2)
' ENER NEW GROUP ACRONYM ABOVE

If ans9 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "OCH" ' ENTER NEW GROUP ACRONYM

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("rkk").Select ' IF A NEW TAB IS CREATED THEN CHANGE THE SHEET
NAME TO RELFECT NEW TAB

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

' End OCH

'Import RKK

Range("B2").Select

Dim ans10 As Long
ans10 = MsgBox("Import Data for ""RKK""?", vbYesNo + vbQuestion +
vbDefaultButton2)
' ENER NEW GROUP ACRONYM ABOVE

If ans10 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "RKK" ' ENTER NEW GROUP ACRONYM

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("hbg").Select

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

' End RKK

'IMPORT HBG

Range("B2").Select

Dim ans11 As Long
ans11 = MsgBox("Import Data for ""HBG""?", vbYesNo + vbQuestion +
vbDefaultButton2)

If ans11 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "HBG"

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("LMP").Select ' IF A NEW TAB IS CREATED THEN CHANGE THE SHEET
NAME TO RELFECT NEW TAB

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

' End HBG

'IMPORT LMP

Range("B2").Select

Dim ans12 As Long ' Change XXX to next number in sequence
ans12 = MsgBox("Import Data for ""LMP""?", vbYesNo + vbQuestion +
vbDefaultButton2)
' ENER NEW GROUP ACRONYM ABOVE

If ans12 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "LMP" ' ENTER NEW GROUP ACRONYM

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste
Sheets("NFH").Select ' IF A NEW TAB IS CREATED THEN CHANGE THE SHEET
NAME TO RELFECT NEW TAB

Else

ActiveSheet.Next.Select

On Error Resume Next

End If

' End LMP

'IMPORT NEW TAB

' Range("B2").Select

' Dim ansXXX As Long ' Change XXX to next number in sequence
' ansXXX = MsgBox("Import Data for ""XXX""?", vbYesNo + vbQuestion +
vbDefaultButton2)
' ENER NEW GROUP ACRONYM ABOVE

' If ansXXX = vbYes Then

' Range("B2").Select
' Selection.QueryTable.Refresh BackgroundQuery:=False
' Range("A2").Select
' Range(Selection, Selection.End(xlDown)).ClearContents

'Update

' Range("A2").Select
' Range("A2") = "XXX" ' ENTER NEW GROUP ACRONYM

' If Range("B3") = "" Then

' do nothing

' Else

' LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
' col = ActiveCell.Column
' FormulaRow = ActiveCell.Row
' Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

' End If

'copy paste

' LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
' Range("A2:G" & LastRow).Select
' Selection.Copy
' Sheets("bluecard_homeplanaid").Select

' With Columns(1)

' Set C = .Find(what:="", after:=Cells(3, 1))

' C.Select

' End With

' ActiveSheet.Paste
' Sheets("XXX").Select ' IF A NEW TAB IS CREATED THEN CHANGE THE SHEET
NAME TO RELFECT NEW TAB

'Else

'ActiveSheet.Next.Select

'On Error Resume Next

'End If

' End NEW TAB

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'NEW TAB ABOVE 'NEW TAB ABOVE 'NEW TAB ABOVE 'NEW TAB ABOVE 'NEW TAB ABOVE

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'IMPORT NFH (FINAL IMPORT)

Range("B2").Select

Dim ans750 As Long
ans750 = MsgBox("Import Data for ""NFH""?", vbYesNo + vbQuestion +
vbDefaultButton2)

If ans750 = vbYes Then

Range("B2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Update

Range("A2").Select
Range("A2") = "NFH"

If Range("B3") = "" Then

' do nothing

Else

LastRow = ActiveCell.Offset(0, 3).End(xlDown).Row
col = ActiveCell.Column
FormulaRow = ActiveCell.Row
Range(Cells(FormulaRow, col), Cells(LastRow, col)).FillDown

End If

'copy paste

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:G" & LastRow).Select
Selection.Copy
Sheets("bluecard_homeplanaid").Select

With Columns(1)

Set C = .Find(what:="", After:=Cells(3, 1))

C.Select

End With

ActiveSheet.Paste

Else

Sheets("bluecard_homeplanaid").Select

On Error Resume Next

End If

' END NFH

' ***** DO NOT PUT ANOTHER IMPORT HERE. IT MUST BE PLACED BEFORE NFH ******

Peruanos72 · Nov 6, 2009

' BEGIN FINAL UPDATE!!!

Row = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
For Temp = Row To 4 Step -1
If Len(Trim(Range("E" & Temp))) < 16 Then
Rows(Temp).Delete
End If
Next

Range("A4").Select

Sheets(Array("bzv", "kpx", "uco", "hvu", "generic", "bnl", "eca", "fus",
"och", "rkk", "hbg", "lmp", "nfh")).Delete

If Range("A4") = "" Then

'Workbooks("bluecard_homeplanaid_Master").Activate

MsgBox ("There is no data for today." & vbNewLine & _
"Be sure to save this file even though no data exists")

Dim ans14 As Long
ans14 = MsgBox("Is today Monday?", vbYesNo + vbQuestion +
vbDefaultButton2, "Report Date Confirmation")

If ans14 = vbYes Then

Range("rep_date") = Date - 3
Range("date") = Date
Range("rep_date").Select
Selection.NumberFormat = "mm.dd.yy"
ActiveSheet.Name = "Bluecard_homeplanaid_" & Range("B2").Text
Range("rep_date").NumberFormat = "mm/dd/yyyyy"

Else

Range("rep_date") = Date - 1
Range("date") = Date
Range("rep_date").Select
Selection.NumberFormat = "mm.dd.yy"
ActiveSheet.Name = "Bluecard_homeplanaid_" & Range("B2").Text
Range("rep_date").NumberFormat = "mm/dd/yyyyy"

End If

' Delete Button

ActiveSheet.Shapes("Button 1").Select
Selection.Delete
ActiveSheet.Shapes("Button 3").Select
Selection.Delete
ActiveSheet.Shapes("Button 4").Select
Selection.Delete
ActiveSheet.Shapes("Picture 2").Select
Selection.Delete
Range("A4").Select

' add subtotal

Rows("3:3").Select
Selection.Insert Shift:=xlDown
Range("A3").Select
ActiveCell.FormulaR1C1 = "Total:"
Range("B3").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(2,R[2]C[2]:R[65000]C[2])"
Range("B3").Select
Selection.NumberFormat = "#,##0"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With

' Add "There is no data for today's report" on excel tab

Range("A5:I9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection.Font
.Name = "Century Schoolbook"
.FontStyle = "Regular"
.Size = 18
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ColorIndex = 3
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveCell.FormulaR1C1 = "NO DATA FOR TODAY'S REPORT"
Range("B1").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

' Backup file????

Dim ans_bu As Long

ans_bu = MsgBox("Backup Bluecard Homeplanaid?", vbYesNoCancel +
vbDefaultButton2, "Backup File?")

If ans_bu = vbYes Then

Workbooks("bluecard_homeplanaid_Master").Activate

' remove color from all tabs

Sheets(Array("bzv", "kpx", "uco", "hvu", "generic", "bnl", "eca", "fus",
"och", "rkk", "hbg", "lmp", "nfh")).Select
Sheets("generic").Activate
ActiveWorkbook.Sheets("generic").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("nfh").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bnl").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hvu").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("uco").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("kpx").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bzv").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("eca").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("fus").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("och").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hbg").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("rkk").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("lmp").Tab.ColorIndex = -4142
'ActiveWorkbook.Sheets("xxx").Tab.ColorIndex = -4142 'add new
group for color change
Sheets("bluecard_homeplanaid").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

ActiveWorkbook.Save

ActiveWorkbook.SaveAs Filename:= _
"H:\RBlakeman\RTA
Desk\Reports\backups\bluecard_homeplanaid_master_backup.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWorkbook.Close

Else

Workbooks("bluecard_homeplanaid_Master").Activate

' remove color from all tabs

Sheets(Array("bzv", "kpx", "uco", "hvu", "generic", "bnl", "eca", "fus",
"och", "rkk", "hbg", "lmp", "nfh")).Select
Sheets("generic").Activate
ActiveWorkbook.Sheets("generic").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("nfh").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bnl").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hvu").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("uco").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("kpx").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bzv").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("eca").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("fus").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("och").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("rkk").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hbg").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("lmp").Tab.ColorIndex = -4142
'ActiveWorkbook.Sheets("xxx").Tab.ColorIndex = -4142 'add new
group for color change
Sheets("bluecard_homeplanaid").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

ActiveWorkbook.Save
ActiveWorkbook.Close

End If

Else

' Auto Fit Columns

Sheets("bluecard_homeplanaid").Select
Columns("A:I").EntireColumn.AutoFit

' align left columns E and C

Sheets("bluecard_homeplanaid").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With

Range("A4").Select

' remove lines

Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A4").Select

'remove id numbers with alpha characters.

LastRow = Range("E" & Rows.Count).End(xlUp).Row
For r = LastRow To 4 Step -1
If Not IsNumeric(Cells(r, "E")) Then
Rows(r).Delete
End If
Next

' Unique Records only

Range("A3").Select
Range("A3:G3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.AdvancedFilter Action:=xlFilterInPlace, Unique:=True

Dim ans19 As Long
ans19 = MsgBox("Is today Monday?", vbYesNo + vbQuestion +
vbDefaultButton2, "Report Date Confirmation")

If ans19 = vbYes Then

Range("rep_date") = Date - 3
Range("date") = Date
Range("rep_date").Select
Selection.NumberFormat = "mm.dd.yy"
ActiveSheet.Name = "Bluecard_homeplanaid_" & Range("B2").Text
Range("rep_date").NumberFormat = "mm/dd/yyyyy"

Else

Range("rep_date") = Date - 1
Range("date") = Date
Range("rep_date").Select
Selection.NumberFormat = "mm.dd.yy"
ActiveSheet.Name = "Bluecard_homeplanaid_" & Range("B2").Text
Range("rep_date").NumberFormat = "mm/dd/yyyyy"

End If

' Delete Button

ActiveSheet.Shapes("Button 1").Select
Selection.Delete
ActiveSheet.Shapes("Button 3").Select
Selection.Delete
ActiveSheet.Shapes("Button 4").Select
Selection.Delete
ActiveSheet.Shapes("Picture 2").Select
Selection.Delete
Range("A4").Select

' add subtotal

Rows("3:3").Select
Selection.Insert Shift:=xlDown
Range("A3").Select
ActiveCell.FormulaR1C1 = "Total:"
Range("B3").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(2,R[2]C[2]:R[65000]C[2])"
Range("B3").Select
Selection.NumberFormat = "#,##0"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

Dim ans_bu2 As Long

ans_bu2 = MsgBox("Backup Bluecard Homeplanaid?", vbYesNoCancel +
vbDefaultButton2, "Backup File?")

If ans_bu2 = vbYes Then

Workbooks("bluecard_homeplanaid_Master").Activate

' remove color from all tabs

Sheets(Array("bzv", "kpx", "uco", "hvu", "generic", "bnl", "eca", "fus",
"och", "rkk", "hbg", "lmp", "nfh")).Select
Sheets("generic").Activate
ActiveWorkbook.Sheets("generic").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("nfh").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bnl").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hvu").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("uco").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("kpx").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bzv").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("eca").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("fus").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("och").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("rkk").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hbg").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("lmp").Tab.ColorIndex = -4142
'ActiveWorkbook.Sheets("xxx").Tab.ColorIndex = -4142 'add new
group for color change
Sheets("bluecard_homeplanaid").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

ActiveWorkbook.Save

ActiveWorkbook.SaveAs Filename:= _
"H:\RBlakeman\RTA
Desk\Reports\backups\bluecard_homeplanaid_master_backup.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWorkbook.Close

Else

Workbooks("bluecard_homeplanaid_Master").Activate

' remove color from all tabs

Sheets(Array("bzv", "kpx", "uco", "hvu", "generic", "bnl", "eca", "fus",
"och", "rkk", "hbg", "lmp", "nfh")).Select
Sheets("generic").Activate
ActiveWorkbook.Sheets("generic").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("nfh").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bnl").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hvu").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("uco").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("kpx").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bzv").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("eca").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("fus").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("och").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("rkk").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hbg").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("lmp").Tab.ColorIndex = -4142
'ActiveWorkbook.Sheets("xxx").Tab.ColorIndex = -4142 'add new
group for color change
Sheets("bluecard_homeplanaid").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

ActiveWorkbook.Save
ActiveWorkbook.Close

End If

End If

End Sub

john · Nov 7, 2009

sorry, but do not have time to digest all your code.
can only suggest that you try changing this part

With ThisWorkbook

Set ws1 = .Worksheets("untitled")
Set ws2 = .Worksheets("bluecard_homeplanaid")

End With

'to this

Dim NewBook As Workbook

Set NewBook = ActiveWorkbook

With NewBook

Set ws1 = .Worksheets("untitled")
Set ws2 = .Worksheets("bluecard_homeplanaid")

End With

' if Worksheets("untitled") does not exist in new workbook
'then refer to it by its index number e.g.

With NewBook

Set ws1 = .Worksheets(1)
Set ws2 = .Worksheets("bluecard_homeplanaid")

End With

'where worksheet(1) would be the first worksheet in the workbook

You would call the DeleteData procedure at the point in your code just after
you have made the copy of the worksheets. Copy action creates a new workbook
and thus, it becomes the active workbook so this line Set NewBook =
ActiveWorkbook will ensure that you are referring to the correct workbook in
your code.

As an aside, it is considered good practice to qualify the ranges to their
respective workbook / worksheets. By doing this you can refer to them without
the need to use SELECT or ACTIVATE in your code. But more importantly, you
will ensure that your data ends up in the right place. The use of Range on
its own can give rise to unpredictable results.

You may also want to consider breaking your code down in to more manageable
modules to do specific functions like DeleteData code I provided. You code
would then, be much easier to read & debug.

--
jb

Peruanos72 said:
' BEGIN FINAL UPDATE!!!

Row = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
For Temp = Row To 4 Step -1
If Len(Trim(Range("E" & Temp))) < 16 Then
Rows(Temp).Delete
End If
Next

Range("A4").Select

Sheets(Array("bzv", "kpx", "uco", "hvu", "generic", "bnl", "eca", "fus",
"och", "rkk", "hbg", "lmp", "nfh")).Delete

If Range("A4") = "" Then

'Workbooks("bluecard_homeplanaid_Master").Activate

MsgBox ("There is no data for today." & vbNewLine & _
"Be sure to save this file even though no data exists")

Dim ans14 As Long
ans14 = MsgBox("Is today Monday?", vbYesNo + vbQuestion +
vbDefaultButton2, "Report Date Confirmation")

If ans14 = vbYes Then

Range("rep_date") = Date - 3
Range("date") = Date
Range("rep_date").Select
Selection.NumberFormat = "mm.dd.yy"
ActiveSheet.Name = "Bluecard_homeplanaid_" & Range("B2").Text
Range("rep_date").NumberFormat = "mm/dd/yyyyy"

Else

Range("rep_date") = Date - 1
Range("date") = Date
Range("rep_date").Select
Selection.NumberFormat = "mm.dd.yy"
ActiveSheet.Name = "Bluecard_homeplanaid_" & Range("B2").Text
Range("rep_date").NumberFormat = "mm/dd/yyyyy"

End If

' Delete Button

ActiveSheet.Shapes("Button 1").Select
Selection.Delete
ActiveSheet.Shapes("Button 3").Select
Selection.Delete
ActiveSheet.Shapes("Button 4").Select
Selection.Delete
ActiveSheet.Shapes("Picture 2").Select
Selection.Delete
Range("A4").Select

' add subtotal

Rows("3:3").Select
Selection.Insert Shift:=xlDown
Range("A3").Select
ActiveCell.FormulaR1C1 = "Total:"
Range("B3").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(2,R[2]C[2]:R[65000]C[2])"
Range("B3").Select
Selection.NumberFormat = "#,##0"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With

' Add "There is no data for today's report" on excel tab

Range("A5:I9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection.Font
.Name = "Century Schoolbook"
.FontStyle = "Regular"
.Size = 18
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ColorIndex = 3
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveCell.FormulaR1C1 = "NO DATA FOR TODAY'S REPORT"
Range("B1").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

' Backup file????

Dim ans_bu As Long

ans_bu = MsgBox("Backup Bluecard Homeplanaid?", vbYesNoCancel +
vbDefaultButton2, "Backup File?")

If ans_bu = vbYes Then

Workbooks("bluecard_homeplanaid_Master").Activate

' remove color from all tabs

Sheets(Array("bzv", "kpx", "uco", "hvu", "generic", "bnl", "eca", "fus",
"och", "rkk", "hbg", "lmp", "nfh")).Select
Sheets("generic").Activate
ActiveWorkbook.Sheets("generic").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("nfh").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bnl").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hvu").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("uco").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("kpx").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bzv").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("eca").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("fus").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("och").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hbg").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("rkk").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("lmp").Tab.ColorIndex = -4142
'ActiveWorkbook.Sheets("xxx").Tab.ColorIndex = -4142 'add new
group for color change
Sheets("bluecard_homeplanaid").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

ActiveWorkbook.Save

ActiveWorkbook.SaveAs Filename:= _
"H:\RBlakeman\RTA
Desk\Reports\backups\bluecard_homeplanaid_master_backup.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWorkbook.Close

Else

Workbooks("bluecard_homeplanaid_Master").Activate

' remove color from all tabs

Sheets(Array("bzv", "kpx", "uco", "hvu", "generic", "bnl", "eca", "fus",
"och", "rkk", "hbg", "lmp", "nfh")).Select
Sheets("generic").Activate
ActiveWorkbook.Sheets("generic").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("nfh").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bnl").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hvu").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("uco").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("kpx").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bzv").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("eca").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("fus").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("och").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("rkk").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hbg").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("lmp").Tab.ColorIndex = -4142
'ActiveWorkbook.Sheets("xxx").Tab.ColorIndex = -4142 'add new
group for color change
Sheets("bluecard_homeplanaid").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

ActiveWorkbook.Save
ActiveWorkbook.Close

End If

Else

' Auto Fit Columns

Sheets("bluecard_homeplanaid").Select
Columns("A:I").EntireColumn.AutoFit

' align left columns E and C

Sheets("bluecard_homeplanaid").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With

Range("A4").Select

' remove lines

Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A4").Select

'remove id numbers with alpha characters.

LastRow = Range("E" & Rows.Count).End(xlUp).Row
For r = LastRow To 4 Step -1
If Not IsNumeric(Cells(r, "E")) Then
Rows(r).Delete
End If
Next

' Unique Records only

Range("A3").Select
Range("A3:G3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.AdvancedFilter Action:=xlFilterInPlace, Unique:=True

Dim ans19 As Long
ans19 = MsgBox("Is today Monday?", vbYesNo + vbQuestion +
vbDefaultButton2, "Report Date Confirmation")

If ans19 = vbYes Then

Range("rep_date") = Date - 3
Range("date") = Date
Range("rep_date").Select
Selection.NumberFormat = "mm.dd.yy"
ActiveSheet.Name = "Bluecard_homeplanaid_" & Range("B2").Text
Range("rep_date").NumberFormat = "mm/dd/yyyyy"

Else

Peruanos72 · Nov 9, 2009

Thanks for your help.. I give this a try

john said:
sorry, but do not have time to digest all your code.
can only suggest that you try changing this part

With ThisWorkbook

Set ws1 = .Worksheets("untitled")
Set ws2 = .Worksheets("bluecard_homeplanaid")

End With

'to this

Dim NewBook As Workbook

Set NewBook = ActiveWorkbook

With NewBook

Set ws1 = .Worksheets("untitled")
Set ws2 = .Worksheets("bluecard_homeplanaid")

End With

' if Worksheets("untitled") does not exist in new workbook
'then refer to it by its index number e.g.

With NewBook

Set ws1 = .Worksheets(1)
Set ws2 = .Worksheets("bluecard_homeplanaid")

End With

'where worksheet(1) would be the first worksheet in the workbook

You would call the DeleteData procedure at the point in your code just after
you have made the copy of the worksheets. Copy action creates a new workbook
and thus, it becomes the active workbook so this line Set NewBook =
ActiveWorkbook will ensure that you are referring to the correct workbook in
your code.

As an aside, it is considered good practice to qualify the ranges to their
respective workbook / worksheets. By doing this you can refer to them without
the need to use SELECT or ACTIVATE in your code. But more importantly, you
will ensure that your data ends up in the right place. The use of Range on
its own can give rise to unpredictable results.

You may also want to consider breaking your code down in to more manageable
modules to do specific functions like DeleteData code I provided. You code
would then, be much easier to read & debug.

--
jb

Peruanos72 said:

' BEGIN FINAL UPDATE!!!

Row = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
For Temp = Row To 4 Step -1
If Len(Trim(Range("E" & Temp))) < 16 Then
Rows(Temp).Delete
End If
Next

Range("A4").Select

Sheets(Array("bzv", "kpx", "uco", "hvu", "generic", "bnl", "eca", "fus",
"och", "rkk", "hbg", "lmp", "nfh")).Delete

If Range("A4") = "" Then

'Workbooks("bluecard_homeplanaid_Master").Activate

MsgBox ("There is no data for today." & vbNewLine & _
"Be sure to save this file even though no data exists")

Dim ans14 As Long
ans14 = MsgBox("Is today Monday?", vbYesNo + vbQuestion +
vbDefaultButton2, "Report Date Confirmation")

If ans14 = vbYes Then

Range("rep_date") = Date - 3
Range("date") = Date
Range("rep_date").Select
Selection.NumberFormat = "mm.dd.yy"
ActiveSheet.Name = "Bluecard_homeplanaid_" & Range("B2").Text
Range("rep_date").NumberFormat = "mm/dd/yyyyy"

Else

Range("rep_date") = Date - 1
Range("date") = Date
Range("rep_date").Select
Selection.NumberFormat = "mm.dd.yy"
ActiveSheet.Name = "Bluecard_homeplanaid_" & Range("B2").Text
Range("rep_date").NumberFormat = "mm/dd/yyyyy"

End If

' Delete Button

ActiveSheet.Shapes("Button 1").Select
Selection.Delete
ActiveSheet.Shapes("Button 3").Select
Selection.Delete
ActiveSheet.Shapes("Button 4").Select
Selection.Delete
ActiveSheet.Shapes("Picture 2").Select
Selection.Delete
Range("A4").Select

' add subtotal

Rows("3:3").Select
Selection.Insert Shift:=xlDown
Range("A3").Select
ActiveCell.FormulaR1C1 = "Total:"
Range("B3").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(2,R[2]C[2]:R[65000]C[2])"
Range("B3").Select
Selection.NumberFormat = "#,##0"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With

' Add "There is no data for today's report" on excel tab

Range("A5:I9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection.Font
.Name = "Century Schoolbook"
.FontStyle = "Regular"
.Size = 18
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ColorIndex = 3
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveCell.FormulaR1C1 = "NO DATA FOR TODAY'S REPORT"
Range("B1").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

' Backup file????

Dim ans_bu As Long

ans_bu = MsgBox("Backup Bluecard Homeplanaid?", vbYesNoCancel +
vbDefaultButton2, "Backup File?")

If ans_bu = vbYes Then

Workbooks("bluecard_homeplanaid_Master").Activate

' remove color from all tabs

Sheets(Array("bzv", "kpx", "uco", "hvu", "generic", "bnl", "eca", "fus",
"och", "rkk", "hbg", "lmp", "nfh")).Select
Sheets("generic").Activate
ActiveWorkbook.Sheets("generic").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("nfh").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bnl").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hvu").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("uco").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("kpx").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bzv").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("eca").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("fus").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("och").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hbg").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("rkk").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("lmp").Tab.ColorIndex = -4142
'ActiveWorkbook.Sheets("xxx").Tab.ColorIndex = -4142 'add new
group for color change
Sheets("bluecard_homeplanaid").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

ActiveWorkbook.Save

ActiveWorkbook.SaveAs Filename:= _
"H:\RBlakeman\RTA
Desk\Reports\backups\bluecard_homeplanaid_master_backup.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWorkbook.Close

Else

Workbooks("bluecard_homeplanaid_Master").Activate

' remove color from all tabs

Sheets(Array("bzv", "kpx", "uco", "hvu", "generic", "bnl", "eca", "fus",
"och", "rkk", "hbg", "lmp", "nfh")).Select
Sheets("generic").Activate
ActiveWorkbook.Sheets("generic").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("nfh").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bnl").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hvu").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("uco").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("kpx").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("bzv").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("eca").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("fus").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("och").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("rkk").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("hbg").Tab.ColorIndex = -4142
ActiveWorkbook.Sheets("lmp").Tab.ColorIndex = -4142
'ActiveWorkbook.Sheets("xxx").Tab.ColorIndex = -4142 'add new
group for color change
Sheets("bluecard_homeplanaid").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowDeletingRows:=True, AllowFiltering:=True

ActiveWorkbook.Save
ActiveWorkbook.Close

End If

Else

' Auto Fit Columns

Sheets("bluecard_homeplanaid").Select
Columns("A:I").EntireColumn.AutoFit

' align left columns E and C

Sheets("bluecard_homeplanaid").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection

Click to expand...