help with old code now work has changed output formats

[mercmannick]

Hi All

can anyone have a look at some code, i have been off ill for 6 mnths and before this i had soem code that would combine 2 sheets do some other stuff and , now when we run the reports in work to get the 2 old files it is combined i can email , the sheets if anyone could help me out, a cpl people on here helped me back then to create it but i cant get my head round trying to make it work with one sheet instead of 2

Thanks

Merc

[Norie]

merc

It might help to see the code.

And also some more information on what's changed.

[mercmannick]

Hi norie

sorry i panicking a bit lol

i will include code and sheets in post now

thanks

Merc

[mercmannick]

[VBA]Option Explicit
Option Compare Text
'Defines name of Summary Sheet
Private Const SUMMARY_NAME As String = "Master Sheet"
'Defines header rows for each data sheet
Private Const HEADER_ROWS As String = "1:5"
'Defines the beginning row on each data sheet
Private Const START_ROW As String = "6:6"
Sub Shortage_Report()
' Macro by MercManNick
Dim Rng As Range
Dim iRow As Long
'AP: each variable need to have its data type defined
Dim iLastRow As Long, iLastRow2 As Long, iLastRow3 As Long
Dim wbkReport As Workbook
Dim shtReport As Worksheet
Dim datDate As Date
Dim lngIndex As Long
Dim vntItems As Variant
Dim lngRow As Long
Call StopStuff(False)
Call Refresh_Data
'AP: Use object variables
Set wbkReport = Workbooks("s40 s70 shortage report wk" & MyWeekNum(Date) & ".xls")
Set shtReport = wbkReport.Sheets("zflex")


iLastRow3 = shtReport.Range("A65536").End(xlUp).Row

For Each Rng In shtReport.Range("I2:I" & iLastRow3)

Rng.EntireRow.Range("A1").Formula = "=ROW()-1" ' incremental value

Select Case Rng.Value
Case "PurchReq"
With Rng
.Font.Bold = True
.Font.ColorIndex = 5
End With
Case "QM-Lot"
With Rng
.Font.Bold = True
.Font.ColorIndex = 50
End With
Case "planned"
With Rng
.Font.ColorIndex = 38
.Font.Bold = True
End With
End Select

If Len(Rng.Offset(0, -1).Value) > 0 Then ' check date of Z Flex promise
With Rng.Offset(0, -1)
datDate = DateSerial(CInt(Mid(.Text, 7, 4)), Mid(.Value, 4, 2), Left(.Value, 2))
If datDate <= Date Then
.Font.Bold = True
.Font.color = vbRed
End If
End With
End If

If Len(Rng.Offset(0, -4).Value) > 0 Then ' check date of RepDate
With Rng.Offset(0, -4)
datDate = DateSerial(CInt(Mid(.Text, 7, 4)), Mid(.Value, 4, 2), Left(.Value, 2))
If datDate <= Date Then
.Font.Bold = True
.Font.color = vbRed
End If
End With
End If

Next Rng

' Items in col C when matched deleted row
vntItems = Array("Test", "Another Test")
For lngRow = iLastRow3 To 3 Step -1
For lngIndex = LBound(vntItems) To UBound(vntItems)
If shtReport.Cells(lngRow, 3).Value = vntItems(lngIndex) Then
shtReport.Cells(lngRow, 3).EntireRow.Delete
Exit For
End If
Next
Next

Call StopStuff(True)

End Sub


Public Sub Dupe_Remover()
'29/06/2005 by nhunter
Application.ScreenUpdating = False
Dim R1 As Range
Dim drow As Integer
Dim lastitem As String
Set R1 = ActiveCell
loopst:

If Trim(ActiveCell) = "" Then
GoTo procend
End If


If lastitem <> R1.Offset(drow, 0) Then
lastitem = R1.Offset(drow, 0).Value
drow = drow + 1
Else
Rows(R1.Offset(drow, 0).Row).Select
Selection.Delete Shift:=xlUp
R1.Offset(drow, 0).Select
End If

GoTo loopst
procend:
Application.ScreenUpdating = True
End Sub






Public Sub StopStuff(ByVal x As Boolean)
With Application
.CutCopyMode = x
.ScreenUpdating = x
.EnableEvents = x
.DisplayAlerts = x
End With
End Sub
Private Sub Refresh_Data()
'12/05/2006 by Nick
'AP: each variable type
Dim Lastrow As Long, lastrow2 As Long, lastrow3 As Long, lastrow4 As Long, Finalrow As Long
Dim wbkReport As Workbook
Dim shtReport As Worksheet
Dim wbkFileB As Workbook
Dim shtFileB As Worksheet
Dim wbkFileI As Workbook
Dim shtFileI As Worksheet

'Call StopStuff(False)

'Set wbkReport = Workbooks.Open(Filename:="H:\Excel\s40 s70 shortage report wk" & MyWeekNum(Date) & ".xls")
'Set wbkFileB = Workbooks.Open(Filename:="H:\Excel\B01-S121 zflex.xls")
'Set wbkFileI = Workbooks.Open(Filename:="H:\Excel\Io1-I99 zflex.xls")

Set wbkReport = Workbooks("s40 s70 shortage report wk" & MyWeekNum(Date) & ".xls")
Set shtReport = wbkReport.Sheets("zflex")
Set wbkFileB = Workbooks("B01-S121 zflex.xls")
Set wbkFileI = Workbooks("Io1-I99 zflex.xls")
Set shtFileI = wbkFileI.Sheets("Io1-I99 zflex")

Lastrow = shtFileI.Range("B65536").End(xlUp).Row ' determine lastrow 1654
shtFileI.Copy Before:=wbkFileB.Sheets(1)

' Call ConsolidateWorksheets

lastrow3 = shtReport.Range("A65536").End(xlUp).Row ' determine lastrow
shtReport.Range("A2:CI" & lastrow3).ClearContents ' delete old data

lastrow2 = wbkFileB.Sheets("Master Sheet").Range("B65536").End(xlUp).Row ' determine lastrow 105
Finalrow = lastrow2 + 1
wbkFileB.Sheets("Master Sheet").Range("A1:CJ" & lastrow2).Copy Destination:= _
shtReport.Range("A1") ' copy to main sheet

lastrow4 = shtReport.Range("b65536").End(xlUp).Row

shtReport.Range("b5:cI" & lastrow4).Sort Key1:=shtReport.Range("B2"), Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

shtReport.Copy After:=shtReport
wbkFileI.Close
wbkFileB.Close
shtReport.Select
shtReport.Range("B2").Activate
Call Remove_E_H_Ts
Call Dupe_Remover
Call SetDateFomat

'shtReport.Range("A2:I" & lastrow4).Sort Key1:=shtReport.Range("C2"), Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'shtReport.Range("C2").Activate

'Call Dupe_Remover

Call StopStuff(True)

End Sub
Public Sub SetDateFomat()
Dim strFileName As String
Range("E:E,H:H").Replace What:=".", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
With Range("A:I")
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With

'Call SaveAs

End Sub
Public Sub ConsolidateWorksheets()
Dim wsMaster As Worksheet
Dim Ws As Worksheet
Dim blnCopyHeader As Boolean
Dim intHeaderCount As Integer
Dim rngCopy As Range, rngPaste As Range

intHeaderCount = Range(HEADER_ROWS).Rows.Count
' Delete previous version of Master Sheet
For Each Ws In ActiveWorkbook.Worksheets
If Ws.Name = SUMMARY_NAME Then
Ws.Delete
Exit For
End If
Next Ws

Set wsMaster = ActiveWorkbook.Worksheets.Add
wsMaster.Name = SUMMARY_NAME
blnCopyHeader = False
For Each Ws In ActiveWorkbook.Worksheets
' Copy the header rows from the first data sheet only
If Ws.Name <> SUMMARY_NAME Then
If blnCopyHeader = False Then
blnCopyHeader = True
Ws.Range(HEADER_ROWS).Copy
With wsMaster
.Activate
.Range(HEADER_ROWS).PasteSpecial
End With
End If
' Copy the entire used range and paste to the first available row on the Master
Set rngCopy = Ws.UsedRange.Offset(intHeaderCount, 0).EntireRow
rngCopy.Copy
With wsMaster
.Activate
Set rngPaste = .Cells(.UsedRange.Rows.Count, 1)
' Ensure enough blank rows exist to copy data
If rngPaste.Row + rngCopy.Rows.Count > .Rows.Count Then
MsgBox "The maximum row number (" & .Rows.Count & _
" rows) has been exceeded. The worksheet " & Ws.Name & _
"will not be copied to the Master Sheet. Program ending..."
Exit Sub
End If
End With
rngPaste.PasteSpecial
End If
Next Ws
End Sub
Public Sub SaveAs()
'MyWeekNum = DatePart("ww", d)
ActiveWorkbook.SaveAs Filename:="H:\Excel\s40 s70 shortage report wk" & MyWeekNum(Date) & ".xls"
End Sub
Function MyWeekNum(D) As Long
Dim NoOfDays As Long

NoOfDays = DateDiff("d", DateSerial(Year(D), 1, 1), D)
NoOfDays = NoOfDays + (Weekday(DateSerial(Year(D), 1, 1)) - 1)
MyWeekNum = Int(NoOfDays / 7) + 1
End Function

Sub Remove_E_H_Ts()
Dim r As Long
Dim Rng As Range
Dim x&

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual '***set calculation to manual

For x = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1 '***set coumn 2 as range
With Cells(x, 4)
Select Case Left(.Value, 1)
Case "E", "H", "T" '***clear H,T,E from column 2
.EntireRow.ClearContents
Case Else
'do nothing
End Select
End With
Next x

Set Rng = ActiveSheet.UsedRange.Rows '***set rng as used range

For r = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Rng.Rows(r).EntireRow) = 0 Then '***delete blank rows
Rng.Rows(r).EntireRow.Delete
End If
Next r

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub
[/VBA]

[mercmannick]

here are the sheets

Merc

[Bob Phillips]

I think you need to explain the problem a bit more fully, what should it do, what does it do, where does it fail?

[mercmannick]

wont let me upload sheets

Merc

[mercmannick]

xld hi

you would need the sheets to see beginning and outcome of code it dosent fail or error out , as work has changed the way the reports are now output into a single file and headings and columns in diffrent place, and the code is way to advanced for me to work out what part is doing what as the end result is not how it should be .

Merc

[mercmannick]

here is a workbook with all sheets needed

Thanks

Merc

[mercmannick]

anyone have a look at this for me and give m little help plz

Merc

[mdmackillop]

If you're just looking to reformat the new combined sheet, try
[VBA]Sub DoFormat()
With Sheets("new combined file")
.Range("B:B,C:C,E:F,H:I,K:L,N:N,P:P,R:S,U:V,X:AN").Delete
.Range("B3") = "Z FLEX Promise"
.Range("C3") = "CUSTOMER "
.Range("D3") = "Rep Date"
.Range("E3") = "Short Materials"
.Range("F3") = "Short MRP"
.Range("G3") = "Rep Order"
.Range("H3") = "Del Sched Note"
.Range("I3") = "Qty Short"
.Range("B3").Font.ColorIndex = 3
With .Range("B3:I3")
.Interior.ColorIndex = 15
.Font.Bold = True
.Columns.AutoFit
.Borders.LineStyle = xlContinuous
End With
End With
End Sub
[/VBA]

[mercmannick]

mdmackillop

as there is a lot of other chores to do with the data this wont work,
i have to delete all begins with E, H, T from short mat col
data sort same col and remove dupes , check dates if later than today in both date cols red and bold, highlight "planned" blue in rep order col, highlight Purchreq green and qm lot of same col,all del sched col should be blue, put a row no in col a,

then you have to do almost similar to internal sheet

and anything from both sheets beginining with M in short mat col goes in A400 sheet same setup as other two



thanks

Merc

[mdmackillop]

Hi Merc,
You seem to have some code already, Remove Dupes for example. If there is a problem with it, let us know.
With regard to the rest, none sounds to problematical, but you need to take the time to detail exactly what you require. 'highlight "planned" blue' is not specific - Colour cells or text?
There are a few simple processes required here which need to be joined together. Have you tried recording/amending your own code? If so, please post your attempts so we can assist.

[mercmannick]

[VBA]Option Explicit
Option Compare Text
'Defines name of Summary Sheet
Private Const SUMMARY_NAME As String = "zflex s70"
'Defines header rows for each data sheet
Private Const HEADER_ROWS As String = "1:5"
'Defines the beginning row on each data sheet
Private Const START_ROW As String = "6:6"
Sub Shortage_Report_For_S70()
' Macro by MercManNick
Dim Rng As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim iRow As Long
Dim iLastRow4 As Long, iLastRow2 As Long, iLastRow3 As Long
Dim wbkReport As Workbook
Dim shtFileINT As Worksheet
Dim shtFileA400M As Worksheet
Dim shtFileEXT As Worksheet
Dim datDate As Date
Dim lngIndex As Long
Dim vntItems As Variant
Dim lngRow As Long 'AP: each variable need to have its data type defined

Call StopStuff(False)
Call Refresh_Data

'AP: Use object variables

Set wbkReport = Workbooks("s40 s70 shortage report wk" & MyWeekNum(Date) + 1 & ".xls")
Set shtFileINT = wbkReport.Sheets("Internal")
Set shtFileEXT = wbkReport.Sheets("External")
Set shtFileA400M = wbkReport.Sheets("A400M")


iLastRow2 = shtFileINT.Range("A65536").End(xlUp).Row ' determine lastrow
iLastRow3 = shtFileEXT.Range("A65536").End(xlUp).Row ' determine lastrow
iLastRow4 = shtFileA400M.Range("A65536").End(xlUp).Row ' determine lastrow

For Each Rng In shtFileINT.Range("I2:I" & iLastRow3)

Rng.EntireRow.Range("A2").Formula = "=ROW()-1" ' incremental value

Select Case Rng.Value
Case "PurchReq"
With Rng
.Font.Bold = True
.Font.ColorIndex = 5
End With
Case "QM-Lot"
With Rng
.Font.Bold = True
.Font.ColorIndex = 50
End With
Case "planned"
With Rng
.Font.ColorIndex = 38
.Font.Bold = True
End With
End Select

If Len(Rng.Offset(0, -1).Value) > 0 Then ' check date of Z Flex promise
With Rng.Offset(0, -1)
datDate = DateSerial(CInt(Mid(.Text, 7, 4)), Mid(.Value, 4, 2), Left(.Value, 2))
If datDate <= Date Then
.Font.Bold = True
.Font.color = vbRed
End If
End With
End If

If Len(Rng.Offset(0, -4).Value) > 0 Then ' check date of RepDate
With Rng.Offset(0, -4)
datDate = DateSerial(CInt(Mid(.Text, 7, 4)), Mid(.Value, 4, 2), Left(.Value, 2))
If datDate <= Date Then
.Font.Bold = True
.Font.color = vbRed
End If
End With
End If

Next Rng


For Each Rng2 In shtFileEXT.Range("I2:I" & iLastRow3)

Rng2.EntireRow.Range("A2").Formula = "=ROW()-1" ' incremental value

Select Case Rng2.Value
Case "PurchReq"
With Rng2
.Font.Bold = True
.Font.ColorIndex = 5
End With
Case "QM-Lot"
With Rng2
.Font.Bold = True
.Font.ColorIndex = 50
End With
Case "planned"
With Rng2
.Font.ColorIndex = 38
.Font.Bold = True
End With
End Select

If Len(Rng2.Offset(0, -1).Value) > 0 Then ' check date of Z Flex promise
With Rng2.Offset(0, -1)
datDate = DateSerial(CInt(Mid(.Text, 7, 4)), Mid(.Value, 4, 2), Left(.Value, 2))
If datDate <= Date Then
.Font.Bold = True
.Font.color = vbRed
End If
End With
End If

If Len(Rng2.Offset(0, -4).Value) > 0 Then ' check date of RepDate
With Rng2.Offset(0, -4)
datDate = DateSerial(CInt(Mid(.Text, 7, 4)), Mid(.Value, 4, 2), Left(.Value, 2))
If datDate <= Date Then
.Font.Bold = True
.Font.color = vbRed
End If
End With
End If

Next Rng2


For Each Rng3 In shtFileA400M.Range("I2:I" & iLastRow3)

Rng3.EntireRow.Range("A2").Formula = "=ROW()-1" ' incremental value

Select Case Rng3.Value
Case "PurchReq"
With Rng3
.Font.Bold = True
.Font.ColorIndex = 5
End With
Case "QM-Lot"
With Rng3
.Font.Bold = True
.Font.ColorIndex = 50
End With
Case "planned"
With Rng3
.Font.ColorIndex = 38
.Font.Bold = True
End With
End Select

If Len(Rng3.Offset(0, -1).Value) > 0 Then ' check date of Z Flex promise
With Rng3.Offset(0, -1)
datDate = DateSerial(CInt(Mid(.Text, 7, 4)), Mid(.Value, 4, 2), Left(.Value, 2))
If datDate <= Date Then
.Font.Bold = True
.Font.color = vbRed
End If
End With
End If

If Len(Rng3.Offset(0, -4).Value) > 0 Then ' check date of RepDate
With Rng3.Offset(0, -4)
datDate = DateSerial(CInt(Mid(.Text, 7, 4)), Mid(.Value, 4, 2), Left(.Value, 2))
If datDate <= Date Then
.Font.Bold = True
.Font.color = vbRed
End If
End With
End If

Next Rng3

Call StopStuff(True)

End Sub
Public Sub Dupe_Remover()
'29/06/2005 by nhunter
Application.ScreenUpdating = False
Dim R1 As Range
Dim drow As Integer
Dim lastitem As String
Set R1 = ActiveCell
loopst:

If Trim(ActiveCell) = "" Then
GoTo procend
End If


If lastitem <> R1.Offset(drow, 0) Then
lastitem = R1.Offset(drow, 0).Value
drow = drow + 1
Else
Rows(R1.Offset(drow, 0).Row).Select
Selection.Delete Shift:=xlUp
R1.Offset(drow, 0).Select
End If

GoTo loopst
procend:
Application.ScreenUpdating = True
End Sub
Public Sub StopStuff(ByVal x As Boolean)
With Application
.CutCopyMode = x
.ScreenUpdating = x
.EnableEvents = x
.DisplayAlerts = x
End With
End Sub
Private Sub Refresh_Data()
'12/05/2006 by Nick
'AP: each variable type
Dim Lastrow As Long, lastrow2 As Long, lastrow3 As Long, lastrow4 As Long, Finalrow As Long
Dim wbkReport As Workbook
Dim shtReport As Worksheet
Dim wbkFileB As Workbook
Dim shtFileB As Worksheet
Dim shtFileINT As Worksheet
Dim shtFileA400M As Worksheet
Dim shtFileEXT As Worksheet

Call StopStuff(False)

'Set wbkReport = Workbooks.Open(Filename:="c:\Excel\s40 s70 shortage report wk" & MyWeekNum(Date) + 1 & ".xls")
'Set wbkFileB = Workbooks.Open(Filename:="c:\Excel\zflex s70.xls")
Set wbkReport = Workbooks("s40 s70 shortage report wk" & MyWeekNum(Date) + 1 & ".xls")
Set shtReport = wbkReport.Sheets("zflex s70")
Set shtFileINT = wbkReport.Sheets("Internal")
Set shtFileEXT = wbkReport.Sheets("External")
Set shtFileA400M = wbkReport.Sheets("A400M")
'Set wbkFileB = Workbooks("zflex s70.xls")
'Set shtFileB = wbkFileB.Sheets("zflex s70")

Lastrow = shtReport.Range("B65536").End(xlUp).Row ' determine lastrow 1654
lastrow2 = shtFileINT.Range("C65536").End(xlUp).Row ' determine lastrow 1654
lastrow3 = shtFileEXT.Range("C65536").End(xlUp).Row ' determine lastrow 1654
lastrow4 = shtFileA400M.Range("C65536").End(xlUp).Row ' determine lastrow 1654


'shtFileB.Copy Before:=wbkReport.Sheets(1) ' copy new zflex to s40 s70 short report
'wbkFileB.Close 'close zflex s70.xls
shtFileEXT.Range("A2:I" & lastrow3).ClearContents ' delete old data from external sheet
shtFileINT.Range("A2:I" & lastrow2).ClearContents ' delete old data from internal sheet
shtFileA400M.Range("A2:I" & lastrow4).ClearContents ' delete old data from a400m sheet

shtReport.Range("A:C,E:F,H:I,K:L,N:O,R:S,U:V,X:AJ,AL:AX").EntireColumn.Dele te ' DELETE UNWANTED DATA
shtReport.Range("1:3,5:5").Delete ' DELETE UNWANTED DATA

'this is where i need to transfer the certain data to all 3 sheets

'shtReport.Range("A2:I" & Lastrow).Copy Destination:=shtFileEXT.Range("B2") ' transfer to ext sheet
' shtReport.Range("A2:I" & Lastrow).Copy Destination:=shtFileINT.Range("B2") ' transfer to INT sheet
' shtReport.Range("A2:I" & Lastrow).Copy Destination:=shtFileA400M.Range("B2") ' transfer to A400M sheet

shtReport.Range("A2:A" & Lastrow).Copy
shtFileEXT.Paste Range("H2")
Application.CutCopyMode = False

shtReport.Range("B2:b" & Lastrow).Copy
shtFileEXT.Paste Range("G2")
shtFileINT.Paste Range("F2")
shtFileA400M.Paste Range("G2")
Application.CutCopyMode = False

shtReport.Range("C2:c" & Lastrow).Copy
shtFileEXT.Paste Range("E2")
shtFileINT.Paste Range("E2")
shtFileA400M.Paste Range("E2")
Application.CutCopyMode = False

shtReport.Range("D2:d" & Lastrow).Copy
shtFileEXT.Paste Range("B2")
shtFileINT.Paste Range("B2")
shtFileA400M.Paste Range("B2")
Application.CutCopyMode = False

shtReport.Range("E2:e" & Lastrow).Copy
shtFileEXT.Paste Range("C2")
shtFileINT.Paste Range("C2")
shtFileA400M.Paste Range("C2")
Application.CutCopyMode = False

shtReport.Range("F2:f" & Lastrow).Copy
shtFileEXT.Paste Range("I2")
shtFileINT.Paste Range("G2")
shtFileA400M.Paste Range("I2")
Application.CutCopyMode = False

shtReport.Range("G2:g" & Lastrow).Copy
shtFileEXT.Paste Range("F2")
Application.CutCopyMode = False

shtReport.Range("H2:h" & Lastrow).Copy
shtFileEXT.Paste Range("D2")
shtFileINT.Paste Range("D2")
shtFileA400M.Paste Range("D2")
Application.CutCopyMode = False

shtReport.Range("I2:i" & Lastrow).Copy
shtFileINT.Paste Range("H2")
shtFileA400M.Paste Range("H2")
Application.CutCopyMode = False



shtFileEXT.Sort.SortFields.Add Key:=Range("B2:I" & lastrow3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal ' sort ready to remove dupes

shtFileEXT.Range("B2").Select ' remove anything in col B beginning with E H T
Call Remove_E_H_Ts
Call Dupe_Remover ' remove dupe lines from external sht
Call SetDateFomat

shtFileINT.Sort.SortFields.Add Key:=Range("B2:I" & lastrow3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal ' sort ready to remove dupes

shtFileINT.Range("B2").Select ' remove anything in col B beginning with E H T
Call Remove_E_H_Ts
Call Dupe_Remover ' remove dupe lines from int sht
Call SetDateFomat

shtFileA400M.Sort.SortFields.Add Key:=Range("B2:I" & lastrow3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal ' sort ready to remove dupes

shtFileA400M.Range("B2").Select ' remove anything in col B beginning with E H T
Call Remove_E_H_Ts
Call Dupe_Remover ' remove dupe lines from a400 sht
Call SetDateFomat


Call StopStuff(True)

End Sub
Public Sub SetDateFomat()
Dim strFileName As String
Range("E:E,H:H").Replace What:=".", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
With Range("A:I")
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With

Call SaveAs

End Sub

Public Sub SaveAs()
'MyWeekNum = DatePart("ww", d)
ActiveWorkbook.SaveAs Filename:="c:\Excel\s40 s70 shortage report wk" & MyWeekNum(Date) + 1 & ".xls"
End Sub
Function MyWeekNum(D) As Long
Dim NoOfDays As Long

NoOfDays = DateDiff("d", DateSerial(Year(D), 1, 1), D)
NoOfDays = NoOfDays + (Weekday(DateSerial(Year(D), 1, 1)) - 1)
MyWeekNum = Int(NoOfDays / 7) + 1
End Function

Sub Remove_E_H_Ts()
Dim r As Long
Dim Rng As Range
Dim x&

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual '***set calculation to manual

For x = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1 '***set coumn 2 as range
With Cells(x, 2)
Select Case Left(.Value, 1)
Case "E", "H", "T" '***clear H,T,E from column 2
.EntireRow.ClearContents
Case Else
'do nothing
End Select
End With
Next x

Set Rng = ActiveSheet.UsedRange.Rows '***set rng as used range

For r = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Rng.Rows(r).EntireRow) = 0 Then '***delete blank rows
Rng.Rows(r).EntireRow.Delete
End If
Next r

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub
[/VBA]

Here is my modified code keeps falling over on this line

[VBA]shtFileEXT.Range("B2").Select ' remove anything in col B beginning with E H T[/VBA]

Thanks

Merc