View Full Version : help with old code now work has changed output formats
mercmannick
02-09-2007, 02:42 PM
:banghead:
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
02-09-2007, 02:48 PM
merc
It might help to see the code.:)
And also some more information on what's changed.
mercmannick
02-09-2007, 02:57 PM
Hi norie
sorry i panicking a bit lol
i will include code and sheets in post now
thanks
Merc
mercmannick
02-09-2007, 02:59 PM
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
mercmannick
02-09-2007, 03:04 PM
here are the sheets
Merc
Bob Phillips
02-09-2007, 03:47 PM
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
02-09-2007, 03:47 PM
wont let me upload sheets
Merc
mercmannick
02-09-2007, 03:55 PM
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
02-09-2007, 04:03 PM
here is a workbook with all sheets needed
Thanks
Merc
mercmannick
02-10-2007, 12:54 AM
anyone have a look at this for me and give m little help plz
Merc
mdmackillop
02-10-2007, 05:22 AM
If you're just looking to reformat the new combined sheet, try
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
mercmannick
02-10-2007, 05:38 AM
:think:
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
02-10-2007, 06:00 AM
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
02-10-2007, 10:26 AM
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.Delete ' 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
Here is my modified code keeps falling over on this line
shtFileEXT.Range("B2").Select ' remove anything in col B beginning with E H T
Thanks
Merc
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.