Sub Schedule_Calculator()
' Schedule_Calculator Macro
' Macro recorded 12/16/03 by Setiono
'
Dim E As Integer, kolom As Byte, baris As Integer, MICON As String, Q(10) As Integer
Dim QP(10) As String, n As Byte
E = IsEOF(7, 8)
For n = 1 To 10
Q(n) = 0
Next n
QP(1) = "QXXAVC016---N / IC LC863356B-50P7"
QP(2) = "QXXAVC042---P / IC LC863440W-50E5-TLM"
QP(3) = "QXXAVC044---P / IC LC863440W-50K0-TLM"
QP(4) = "QXXAVC129---P / IC LC863440W-51C2-TLM"
QP(5) = "QXXAVC214A--P / IC LC863440W-52Z8-TLM"
QP(6) = "QXXAVC274---P / IC LC863440W-51T8-TLM"
QP(7) = "QXXAVC305---P / IC LC863448W-52F1-TLM"
QP(8) = "QXXAVC320---P / IC LC863440W-52F2-TLM"
QP(9) = "QXXAVC321---P / IC LC863440W-52F3-TLM"
QP(10) = "QXXAVC410---N / IC ST92195C8B1/MCY"
For n = 1 To 10
Cells(E + n, 2).Value = QP(n)
Next n
For kolom = 10 To 34
For baris = 7 To E
MICON = Cells(baris, 8).Value
Select Case MICON ' Evaluate MICON.
Case "QXXAVC016---N"
Q(1) = Q(1) + Cells(baris, kolom).Value
Case "QXXAVC042---P"
Q(2) = Q(2) + Cells(baris, kolom).Value
Case "QXXAVC044---P"
Q(3) = Q(3) + Cells(baris, kolom).Value
Case "QXXAVC129---P"
Q(4) = Q(4) + Cells(baris, kolom).Value
Case "QXXAVC214A--P"
Q(5) = Q(5) + Cells(baris, kolom).Value
Case "QXXAVC274---P"
Q(6) = Q(6) + Cells(baris, kolom).Value
Case "QXXAVC305---P"
Q(7) = Q(7) + Cells(baris, kolom).Value
Case "QXXAVC320---P"
Q(8) = Q(8) + Cells(baris, kolom).Value
Case "QXXAVC321---P"
Q(9) = Q(9) + Cells(baris, kolom).Value
Case "QXXAVC410---N"
Q(10) = Q(10) + Cells(baris, kolom).Value
Case Else
MsgBox "Part tidak dikenal atau mengandung spasi : " & MICON
End Select
Next baris
For n = 1 To 10
With Cells(baris + n - 1, kolom)
.Font.Bold = False
.NumberFormat = "#,##0"
.Value = Q(n)
End With
Next n
For n = 1 To 10
Q(n) = 0
Next n
Next kolom
For n = 1 To 10
Cells(E + n, 35).FormulaR1C1 = "=SUM(RC[-25]:RC[-1])"
Cells(E + n, 35).NumberFormat = "#,##0"
Next n
For n = 1 To 50
If Cells(E + n, 35).Value > 0 Then
Cells(E + n + 1, 2).Select
For n0 = 1 To 4
Selection.EntireRow.Insert
Next n0
Cells(E + n + 1, 3).Value = "REQUEST"
Cells(E + n + 2, 3).Value = "STOCK + REQUEST - " & Left(Cells(E + n, 2).Value, 13) & " PROD. REQUIREMENT"
Cells(E + n + 3, 3).Value = "DELIVERY"
Cells(E + n + 4, 3).Value = "STOCK + DELIVERY - " & Left(Cells(E + n, 2).Value, 13) & " PROD. REQUIREMENT"
Cells(E + n + 2, 10).FormulaR1C1 = "=RC[-1]+R[-1]C-R[-2]C"
Range(Cells(E + n + 2, 10), Cells(E + n + 2, 34)).FillRight
Cells(E + n + 4, 10).FormulaR1C1 = "=RC[-1]+R[-1]C-R[-4]C"
Range(Cells(E + n + 4, 10), Cells(E + n + 4, 34)).FillRight
End If
Next n
Range(Cells(E + 1, 2), Cells(E + 50, 36)).Select
With Selection
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).LineStyle = xlNone
End With
Range(Cells(E + 1, 7), Cells(E + 50, 36)).Select
With Selection
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideVertical).Weight = xlThin
End With
End Sub
'*********************************** EOF ************************************************
Sub Hybrid_DlvSchedule()
'
' Macro created 10/16/02 by Setiono
'
Dim E As Long, SortKey As String, fname As Variant, bln(12) As String
Dim MyDate
bln(1) = "Jan": bln(2) = "Feb": bln(3) = "Mar": bln(4) = "Apr": bln(5) = "May"
bln(6) = "Jun": bln(7) = "Jul": bln(8) = "Aug": bln(9) = "Sep": bln(10) = "Oct"
bln(11) = "Nov": bln(12) = "Dec"
Application.DisplayAlerts = False
Workbooks.Open FileName:="C:\Documents and Settings\Kristina\My Documents\WORKING DAYS.xls"
ImportDoc "C:\Documents and Settings\Kristina\My Documents\TSFSPLF.P1" 'Plant 1
ActiveWindow.Zoom = 75
VNAME = Cells(4, 2).Value & Cells(4, 3).Value
sdate = Cells(1, 9).Value & Cells(1, 10).Value
bulan = Mid(sdate, 11, 2)
tgl = Mid(sdate, 14, 2)
thn = "200" & Mid(sdate, 9, 1)
fname = VNAME & " - (" & tgl & "-" & bln(Val(bulan)) & "-" & thn & ")"
Do
SortKey = LCase(InputBox("Mau diurut base on apa? Part, Production ato Date ? (Part,Prod,Date)", "Sort Order Confirmation", "Part"))
If SortKey = "" Then Exit Sub
Loop Until SortKey = "part" Or SortKey = "prod" Or SortKey = "date"
Do
Ask = LCase(InputBox("Process Plant X ? (Y/N)", "Plant X Progress Confirmation", "N"))
If Ask = "" Then Exit Sub
Loop Until Ask = "n" Or Ask = "y"
If Ask = "y" Then
ImportDoc "C:\Documents and Settings\Kristina\My Documents\TSFSPLF.PX" 'Plant X
E = IsEOF(9, 1)
Range(Cells(1, 1), Cells(E, 15)).Copy 'Copy Data in TSFSPLF.PX
Windows("TSFSPLF.P1").Activate
E = IsEOF(9, 1) 'Determine Eof Row Usage in TSFSPLS.P1
Cells(E + 1, 1).Select
ActiveSheet.Paste
ActiveSheet.Copy 'Clone the Worksheet
Windows("TSFSPLF.PX").Close
Windows("TSFSPLF.P1").Close
End If
Range("A1:C2").ClearContents 'delete "B1AF30 SYS:INSEIA SOPIS & JOB:...
Range("I1:M1").ClearContents 'PROCESS DATE FROM SOPIS (SUBMITTED DATE)
Range("I1").FormulaR1C1 = "DATE: " & tgl & "-" & bln(Val(bulan)) & "-" & thn
CellTMP = Cells(2, 9).Value & Left(Cells(2, 10), 4) 'PROCESS TIME FROM SOPIS (SUBMITTED TIME)
Range("I2:M2").ClearContents
Range("I2").FormulaR1C1 = CellTMP
Range("D2:G2").ClearContents
Range("D2").FormulaR1C1 = "DELIVERY SCHEDULE LIST BY " & UCase(SortKey)
CellTMP = Cells(4, 1).Value & Cells(4, 2).Value & Cells(4, 3).Value
VC = Left(CellTMP, 15)
VN = Right(CellTMP, Len(CellTMP) - 15)
Range("A4:G4").ClearContents
Range("A4").FormulaR1C1 = VC & " " & VN
CellTMP = Cells(5, 1).Value & Cells(5, 2).Value & Cells(5, 3).Value
Range("A5:G5").ClearContents
Range("A5").FormulaR1C1 = CellTMP
'************************** Eof Formatting Header ****************************
XEndCell = IsEOF(1, 1)
Columns("A:A").ColumnWidth = 15
Columns("B:B").ColumnWidth = 10.29
Columns("C:C").ColumnWidth = 16.43
Columns("E:E").ColumnWidth = 10.29
Columns("K:K").ColumnWidth = 9.86
Columns("L:O").Delete Shift:=xlToLeft
Range("A1").Select
For n = 9 To XEndCell
If Left(Cells(n, 2), 1) <> "X" Then
Cells(n, 2).NumberFormat = "0000000000"
End If
If Cells(n, 10).Value = "0/00/00" Then Cells(n, 10).Value = "" 'Delete ANSWER Column if only 0/00/00
If Left(Cells(n, 1), 6) = "B1AF30" Then
For p = 1 To 8
Cells(n, 1).EntireRow.Delete
Next p
n = n - 1
End If
Next n
E = IsEOF(9, 1)
ConvertDate 5, 9, E
ConvertDate 11, 9, E
Do
Ask2 = LCase(InputBox("Di-adjust gak delivery Date-nya ? (Y/T)", "Konfirmasi adjust tuk delivery date", "T"))
If Ask2 = "" Then Exit Sub
Loop Until Ask2 = "t" Or Ask2 = "y"
If Ask2 = "y" Then
MyDate = #4/1/2002# 'BEGIN DATE OF WORKING DAYS
Columns("L:L").ColumnWidth = 15
Range("L7").Value = "SOPIS DLVDATE"
Range("L8").Value = "-------------------------"
TDate = InputBox("Masukin throwing day-nya:", "Konfirmasi Throwing Day", 3)
Do
Ask = LCase(InputBox("Di-Bold gak kalo ada perubahan dlv date? (Y/T)", "Bold konfirmasi", "T"))
If Ask = "" Then Exit Sub
Loop Until Ask = "y" Or Ask = "t"
For n = 9 To E
Cells(n, 12).Value = Cells(n, 5).Value
Cells(n, 12).NumberFormat = "d-mmm-yy"
If IsEmpty(Cells(n, 11)) Then
Else
If Cells(n, 11).Value < MyDate Then
MsgBox "Delivery date diluar jangkauan"
Else
Cells(n, 13).FormulaR1C1 = "=VLOOKUP(RC[-2],'[WORKING DAYS.xls]Sheet1'!R4C2:R557C3,2,FALSE)"
ConvertCellsContent2Value
On Error Resume Next
Cells(n, 13).Value = Cells(n, 13) - TDate
Cells(n, 5).Select
Selection.FormulaR1C1 = "=VLOOKUP(RC[8],'[WORKING DAYS.xls]Sheet1'!R4C3:R557C4,2,FALSE)"
ConvertCellsContent2Value
Cells(n, 13).ClearContents
End If
End If
If Ask = "y" Then If Cells(n, 5) <> Cells(n, 12) Then Cells(n, 5).Font.Bold = True
Next n
End If
If SortKey = "part" Then
Range("A9:L9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("C9"), Order1:=xlAscending, Key2:=Range("E9") _
, Order2:=xlAscending, Key3:=Range("B9"), Order3:=xlAscending
Range("C7").Select
Range(Selection, Selection.End(xlDown)).Cut
Range("A7").Select
Selection.Insert Shift:=xlToRight
Range("B7").Select
Range(Selection, Selection.End(xlDown)).Cut
Range("D7").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
Range("C7").Select
Range(Selection, Selection.End(xlDown)).Cut
Range("B7").Select
Selection.Insert Shift:=xlToRight
Else
If SortKey = "prod" Then
Range("A9:L9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("A9"), Order1:=xlAscending, Key2:=Range("E9") _
, Order2:=xlAscending, Key3:=Range("C9"), Order3:=xlAscending
Else
Range("A9:L9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("E9"), Order1:=xlAscending
End If
End If
Do
Ask = LCase(InputBox("Split Different " & SortKey & " ? (Y/T)", "Split Confirmation", "T"))
If Ask = "" Then Exit Sub
Loop Until Ask = "y" Or Ask = "t"
If Ask = "y" Then If SortKey = "part" Or SortKey = "prod" Then SplitEngine 9, 1 Else SplitEngine 9, 5
Windows("WORKING DAYS.xls").Activate
ActiveWindow.Close
If Not SortKey = "date" Then
Do
Ask = LCase(InputBox("Hapus pengulangan penulisan " & UCase(SortKey) & "? (Y/T)", "Redundant Delete Confirmation", "T"))
If Ask = "" Then Exit Sub
Loop Until Ask = "y" Or Ask = "t"
End If
If Ask = "y" Then
For n = 9 To IsEOF(1, 1)
If Cells(n, 1) = Cells(n + 1, 1) And Cells(n, 1) = Cells(n + 2, 1) And Cells(n, 1) <> "" Then
Cells(n + 1, 1).Select
Range(Selection, Selection.End(xlDown)).ClearContents
Else
If Cells(n, 1) = Cells(n + 1, 1) And Cells(n, 1) <> "" Then Cells(n + 1, 1).ClearContents
End If
Next n
End If
Range("A1").Select
ActiveWorkbook.SaveAs FileName:="C:\Documents and Settings\Kristina\My Documents\DLVSCHED - " & fname & ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub CheckDoubleMDL_in_PRDSched()
For n = 7 To IsEOF(7, 3)
If Cells(n, 3).Value = Cells(n - 1, 3).Value And _
Cells(n, 4).Value = Cells(n - 1, 4).Value And _
Cells(n, 5).Value = Cells(n - 1, 5).Value Then
Range(Cells(n, 2), Cells(n - 1, 7)).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
If Cells(n, 3).Value = Cells(n + 1, 3).Value And _
Cells(n, 4).Value = Cells(n + 1, 4).Value And _
Cells(n, 5).Value = Cells(n + 1, 5).Value Then
Range(Cells(n, 2), Cells(n + 1, 7)).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
Next
End Sub
Sub CombineWorkbooks()
Dim FilesToOpen
Dim x As Integer
On Error GoTo ErrHandler
Application.ScreenUpdating = False
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
MultiSelect:=True, Title:="Files to Merge")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
While x <= UBound(FilesToOpen)
Workbooks.Open FileName:=FilesToOpen(x)
If x <> 1 Then
Sheets().Copy After:=ThisWorkbook.Sheets _
(ThisWorkbook.Sheets.Count)
End If
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
Sub FormatSAPLSubmittedDlvSchedule()
'
' Macro built 10/4/2002 by Setiono
'
'
Dim swD As Long
Do
Ask = UCase(InputBox("Update Menu No. 7 ? (Y/N)", "Menu 97 Update confirmation", "N"))
Loop Until Ask = "Y" Or Ask = "N"
If Ask = "Y" Then FormatMenuNo7 Else Workbooks.Open FileName:= _
"D:\Menu No 7\Menu07.xls"
Workbooks.Open FileName:= _
"C:\My Documents\WORKING DAYS.xls"
swD = 0
Do
AskDate = LCase(InputBox("Does your Excel have problem with Date Conversion ? (Y/N)", "Date Conversion Problem Confirmation", "N"))
Loop Until AskDate = "n" Or AskDate = "y"
If AskDate = "y" Then swD = 1 Else swD = 0
'******** Import Document *************
ImportDoc "C:\WINDOWS\TSFSPLF.P1"
ImportDoc "C:\WINDOWS\TSFSPLF.PX"
'******** Determine Eof Row Usage in TSFSPLS.PX*****************
Dim p, P1, PX, XEndCell As Long
PX = IsEOF(1, 1)
'******** Make Application Move Silent **************
Application.DisplayAlerts = False
'******** Copy Data in TSFSPLF.PX ***************
Range(Cells(1, 1), Cells(PX, 15)).Copy
Windows("TSFSPLF.P1").Activate
'******** Determine Eof Row Usage in TSFSPLS.P1*****************
P1 = IsEOF(1, 1)
' Determine Cell to paste a copy
Cells(P1, 1).Select
ActiveSheet.Paste
'Clone the Worksheet
ActiveSheet.Select
ActiveSheet.Copy
Columns("A:A").ColumnWidth = 16
Columns("B:B").ColumnWidth = 10.57
Columns("C:C").ColumnWidth = 16
Windows("TSFSPLF.PX").Close
Windows("TSFSPLF.P1").Close
'****************** Formatting SAPL Delivery Scedule Header ********************
Range("H4").FormulaR1C1 = "=CONCATENATE(RC[-7],"" "",RC[-6])"
Range("H4").Select
ConvertCellsContent2Value 'Convert Formulas to Value on Active Cells
Range("A4:G4").Delete Shift:=xlToLeft
Range("H5").FormulaR1C1 = "=CONCATENATE(RC[-7],RC[-6],RC[-5])"
Range("H5").Select
ConvertCellsContent2Value 'Convert Formulas to Value on Active Cells
Range("A5:G5").Delete Shift:=xlToLeft
Range("H1").FormulaR1C1 = "=CONCATENATE(RC[1],LEFT(RC[2],4))"
Range("H1").Select
ConvertCellsContent2Value
Range("I1:M1").ClearContents
Range("H1").Cut Destination:=Range("K4")
Range("H2").FormulaR1C1 = "=CONCATENATE(RC[1],LEFT(RC[2],4))"
Range("H2").Select
ConvertCellsContent2Value
Range("I2:M2").ClearContents
Range("H2").Cut Destination:=Range("K5")
Rows("1:3").Delete Shift:=xlUp
'Make All Part Code Position in Column C to Left side
Columns("C:C").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With
Range("a1").Select
'************************** Eof Formatting Header ****************************
For Counter = 9 To 65536
If Left(Cells(Counter, 1), 6) = "B1AF30" Then
Counter = Counter - 1
For p = 1 To 8
Cells(Counter + 1, 1).EntireRow.Delete
Next p
End If
Next
'******* Determine Eof Usage Row Cell ********
XEndCell = IsEOF(1, 1)
'*********************************************
ConvertDate 5, 6, XEndCell
Columns("E:E").NumberFormat = "d-mmm-yy"
Columns("D:D").Delete Shift:=xlToLeft
Columns("F:F").Delete Shift:=xlToLeft
Columns("H:H").Delete Shift:=xlToLeft
Columns("I:K").Delete Shift:=xlToLeft
Columns("H:H").ColumnWidth = 10
ConvertDate 8, 6, XEndCell
Columns("H:H").NumberFormat = "d-mmm-yy"
Application.CutCopyMode = False
Range("A6", Cells(P1, 9)).Sort Key1:=Range("C6"), Order1:=xlAscending, Key2:=Range("D6") _
, Order2:=xlAscending, Key3:=Range("A6"), Order3:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("J4").FormulaR1C1 = "ISSUING"
Range("J5").FormulaR1C1 = "----------------"
For n = 6 To XEndCell - 1
Cells(n, 10).FormulaR1C1 = "=VLOOKUP(RC[-7],[Menu07.xls]MenuNo7!R2C1:R2824C4,2,FALSE)"
Next n
Columns("J:J").NumberFormat = "d-mmm-yy"
Range(Cells(6, 10), Cells(XEndCell, 10)).Select
ConvertCellsContent2Value
On Error Resume Next
For n = 6 To XEndCell - 1
If Cells(n, 10).Value = "#N/A" Then Cells(n, 10).Value = ""
Next n
Range("A1").Select
'Delete those on theway delivery with no balance
p = 0
For n = 6 To IsEOF(1, 1)
If (Cells(n, 9) = Cells(n, 7)) And (Cells(n, 6) = 0) Then p = p + 1
Next n
For n = 6 To IsEOF(1, 1) - p
If (Cells(n, 9) = Cells(n, 7)) And (Cells(n, 6) = 0) Then
While (Cells(n, 9) = Cells(n, 7)) And (Cells(n, 6) = 0)
Cells(n, 7).EntireRow.Delete
Wend
End If
Next n
Columns("K:K").ColumnWidth = 8.29
Range("K4").Value = "PRB CHK"
Range("K5").Value = "---------"
CurrentDate = Date '+2
SaveDate = 14
Range("L6").Value = CurrentDate '#10/21/2002#
Range("L7").Select
Selection.FormulaR1C1 = _
"=VLOOKUP(R[-1]C,'[WORKING DAYS.xls]Sheet1'!R4C2:R557C3,2,FALSE)"
ConvertCellsContent2Value
Range("L8").Value = Range("L7").Value + SaveDate
Range("L9").Select
Selection.FormulaR1C1 = _
"=VLOOKUP(R[-1]C,'[WORKING DAYS.xls]Sheet1'!R4C3:R557C4,2,FALSE)"
Range("L6").NumberFormat = "d-mmm-yy"
Range("L9").NumberFormat = "d-mmm-yy"
ConvertCellsContent2Value
For n = 6 To IsEOF(1, 1)
If Cells(n, 10) <> "" Then
Cells(n, 11).FormulaR1C1 = "=IF(RC[-1]<R9C[1],""Problem"","""")"
Cells(n, 11).Font.Bold = True
End If
Next n
Columns(11).Select
ConvertCellsContent2Value
Range("J1").Value = "DATE CREATED : "
Range("J2").Value = "DATE COMPARED: "
Range("L1") = Range("L6")
Range("L2") = Range("L9")
Range("l1:l2").Select
Selection.NumberFormat = "d-mmm-yy"
ConvertCellsContent2Value
Range("L6:L9").ClearContents
Range("A6:K6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("K9"), Order1:=xlDescending, Key2:=Range("C9") _
, Order2:=xlAscending, Key3:=Range("D9"), Order3:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("C4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range("A4").Select
Selection.Insert Shift:=xlToRight
Range("B4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range("D4").Select
Selection.Insert Shift:=xlToRight
SplitEngine 6, 1
For n = 6 To IsEOF(1, 1)
If Cells(n, 1) = Cells(n + 1, 1) And Cells(n, 1) = Cells(n + 2, 1) And Cells(n, 1) <> "" Then
Cells(n + 1, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Else
If Cells(n, 1) = Cells(n + 1, 1) And Cells(n, 1) <> "" Then
Cells(n + 1, 1).ClearContents
End If
End If
Next n
Range("A1").Select
'************ Saving WorkMook *******************
ActiveWorkbook.SaveAs FileName:= _
"D:\VENDOR_OS.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Windows("Menu07.xls").Close
Windows("WORKING DAYS.xls").Close
Application.DisplayAlerts = True
End Sub
Sub FormatMenuNo7()
'
' FormatMenuNo7 Macro
' Macro recorded 10/8/02 by Setiono
'
Dim Counter As Long
Application.DisplayAlerts = False
Workbooks.Open FileName:="D:\Menu No 7\MenuNo7"
'******* Make Copy *******************
ActiveSheet.Select
ActiveSheet.Copy
YCell = ActiveCell.Column 'Save Active Cell Position
XCell = ActiveCell.Row
'******* Determine Eof Usage Row Cell ********
XEndCell = IsEOF(1, 1)
'*********************************************
Columns("A:A").Delete Shift:=xlToLeft
Columns("B:B").Insert Shift:=xlToRight
Range("B2").FormulaR1C1 = "=DATE(RC[1],RC[2],RC[3])"
Range("B2", Cells(XEndCell - 1, 2)).Select
Selection.FillDown
Selection.NumberFormat = "dd-mmm-yy"
ConvertCellsContent2Value
Range("C:G,J:W").Delete Shift:=xlToLeft
Columns("A:A").ColumnWidth = 15.57
Columns("B:B").ColumnWidth = 9
Columns("C:C").ColumnWidth = 9
Columns("D:D").ColumnWidth = 11.86
n = 0
p = 0
On Error Resume Next ' Defer error handling.
For n = 2 To XEndCell
If Left(Cells(n, 2), 5) = "#NUM!" Then p = p + 1
Next n
For n = 2 To XEndCell - p
If Left(Cells(n, 2), 5) = "#NUM!" Then
While Left(Cells(n, 2), 5) = "#NUM!"
Cells(n, 2).Select
Selection.EntireRow.Delete
Wend
End If
'Validate Data In Column A and Put Result To Column E
Cells(n, 5) = Cells(n, 1).Value
Next
'Replace Data In Column A With Data In Column E
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Cut
Range("A2").Select
ActiveSheet.Paste
'Make Data Alignment to Left Side
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With
Range("A1").FormulaR1C1 = "PART CODE"
Range("B1").FormulaR1C1 = "ISSUING"
Range("C1").FormulaR1C1 = "BALANCE"
Range("D1").FormulaR1C1 = "PROD#"
'Old Active Cell Select
Cells(XCell, YCell).Select
Windows("MenuNo7").Close
'********************* Saving Document *******************
ActiveWorkbook.SaveAs FileName:= _
"D:\Menu No 7\Menu07.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'*********************************************************
Application.DisplayAlerts = True
End Sub
Sub SplitDifferentItem()
'
' Split Diffrent Item Macro base on ActiveCell Position
' Macro recorded 10/9/02 by Setiono
'
'
Dim Y1Cell As Long, X1Cell As Long
X1Cell = ActiveCell.Column
Y1Cell = ActiveCell.Row
SplitEngine Y1Cell, X1Cell
End Sub
Sub SplitEngine(FirstRow As Long, DiffCol As Long)
'Remove space on Active Cell Column
p = IsEOF(FirstRow, DiffCol)
Range(Cells(FirstRow, DiffCol), Cells(p, DiffCol)).Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
FirstRow = FirstRow + 1
For n = FirstRow To p
If Cells(n, DiffCol) <> Cells(n - 1, DiffCol) Then
c = c + 1
End If
Next n
For n = FirstRow To p + c
If Cells(n, DiffCol) <> Cells(n - 1, DiffCol) Then
Cells(n, DiffCol).EntireRow.Insert
'Rows(n).RowHeight = 10
'Range(Cells(n, 1), Cells(n, 14)).Borders(xlInsideVertical).LineStyle = xlNone
'Range(Cells(n, 1), Cells(n, 14)).Interior.ColorIndex = xlNone
n = n + 1
End If
Next n
End Sub
Sub IncByPercent()
'
' Macro1 Macro
' Macro recorded 7/18/03 by Setiono
'
'
Dim p As Long
br = ActiveCell.Row
bc = ActiveCell.Column
Selection.Cells(Selection.Cells.Count).Select
br1 = ActiveCell.Row
bc1 = ActiveCell.Column
Do
p = UCase(InputBox("Increase by How Many Percent (%)?", "Percent confirmation"))
Loop Until p <> 0
For R = br To br1
For c = bc To bc1
If Cells(R, c).Value <> "" Then
Cells(R, c).Value = Cells(R, c).Value * (1 + (p / 100))
End If
Next c
Next R
End Sub
Sub DecByPercent()
'
' Macro1 Macro
' Macro recorded 7/18/03 by Setiono
'
'
Dim p As Long
br = ActiveCell.Row
bc = ActiveCell.Column
Selection.Cells(Selection.Cells.Count).Select
br1 = ActiveCell.Row
bc1 = ActiveCell.Column
Do
p = UCase(InputBox("Decrease by How Many Percent (%)?", "Percent confirmation"))
Loop Until p <> 0
For R = br To br1
For c = bc To bc1
If Cells(R, c).Value <> "" Then
Cells(R, c).Value = Cells(R, c).Value * (1 - (p / 100))
End If
Next c
Next R
End Sub
Sub SubTotal()
'
' Macro1 Macro
' Macro recorded 10/26/02 by Setiono
'
'
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
i = 0
Counter = 0
For Counter = X1Cell To 65536
If Left(Cells(Counter, Y1Cell), 1) = "" Then
i = i + 1
If Left(Cells(Counter + 1, Y1Cell), 1) = "" Then
If Left(Cells(Counter + 2, Y1Cell), 1) = "" Then
EofR = Counter
Exit For
End If
End If
End If
Next
Do
Ask = UCase(InputBox("Insert 1 row after Total? (Y/N)", "Additional Row Confirmation", "Y"))
Loop Until Ask = "Y" Or Ask = "N"
If Ask = "Y" Then EofR = EofR + i
For n = X1Cell To EofR
If Cells(n, Y1Cell) <> "" Then
V = V + Cells(n, Y1Cell).Value
Else
Cells(n, Y1Cell).Value = V
Cells(n, Y1Cell).Font.Bold = True
Cells(n, Y1Cell).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
V = 0
If Ask = "Y" Then
Rows(n + 1).Select
Selection.Insert Shift:=xlDown
n = n + 1
End If
End If
Next n
'Cells(Y1Cell, X1Cell).Select
End Sub
Sub EraseBlankRow()
Dim Counter, p, M As Long
Counter = 0
p = 0
M = 0
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
'Delete Single Empty Row
For Counter = X1Cell To 65536
If Left(Cells(Counter, Y1Cell), 3) = "" Then
If Left(Cells(Counter + 1, Y1Cell), 3) = "" Then
If Left(Cells(Counter + 2, Y1Cell), 3) = "" Then
p = Counter
Exit For
End If
End If
M = M + 1
End If
Next
For Counter = X1Cell To (p - M)
If Left(Cells(Counter, Y1Cell), 3) = " " Then
Cells(Counter, Y1Cell).EntireRow.Delete
End If
If Left(Cells(Counter, Y1Cell), 3) = "" Then
Cells(Counter, Y1Cell).EntireRow.Delete
End If
If Left(Cells(Counter + 1, Y1Cell), 3) = " " Then
Cells(Counter + 1, Y1Cell).EntireRow.Delete
End If
If Left(Cells(Counter + 1, Y1Cell), 3) = "" Then
Cells(Counter + 1, Y1Cell).EntireRow.Delete
End If
Next
End Sub
Sub FillBlank()
'
' Macro7 Macro
' Macro recorded 10/26/02 by Setiono
'
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
' Selection.Copy
End Sub
Sub FormatInvoice()
'
' FormatSAPLInvoice Macro
' Macro recorded 11/12/02 by Setiono
'
'
Sheets("Sheet1").Select
Sheets("Sheet1").Copy After:=Sheets(1)
Rows("1:4").Delete Shift:=xlUp
EofR = IsEOF(4, 1)
For n = 1 To EofR
If Cells(n, 4) = "" Then Cells(n, 4).EntireRow.Delete
If Left(Cells(n, 4), 4) = "P/O:" Then Cells(n, 4).EntireRow.Delete
If Left(Cells(n, 4), 3) = "SUB" Then Cells(n, 4).EntireRow.Delete
If Left(Cells(n, 4), 5) = "GRAND" Then
For NN = 1 To 7
Cells(n, 4).EntireRow.Delete
Next NN
End If
Next n
Range("D1").Select
EraseBlankRow
Range("D1").Select
EraseBlankRow
Columns("A:B").Delete Shift:=xlToLeft
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
SplitDifferentItem
Range("C1").Select
SubTotal
Range("F1").Select
SubTotal
Columns("D:E").Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.NumberFormat = _
"_([$USD] * #,##0.00_);_([$USD] * (#,##0.00);_([$USD] * ""-""??_);_(@_)"
Selection.ColumnWidth = 20.14
Columns("B:B").Cut
Columns("A:A").Insert Shift:=xlToRight
Range("A1").Select
Sheets("Sheet1 (2)").Select
Sheets("Sheet1 (2)").Copy After:=Sheets(2)
EofR = IsEOF(3, 1)
B = 1
For n = 1 To EofR
If Cells(n, 2) = "" Then
Range(Cells(n, 3), Cells(n, 4)).Cut
Cells(B, 3).Select
ActiveSheet.Paste
B = n + 1
End If
Next n
Range("B1").Select
EraseBlankRow
For n = 2 To IsEOF(2, 1)
If Cells(n, 2).Value = Cells(n - 1, 2).Value Then
While Cells(n, 2).Value = Cells(n - 1, 2).Value And Cells(n, 2).Value <> ""
Cells(n, 2).EntireRow.Delete
Wend
End If
Next n
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Selection.ColumnWidth = 6.14
Range("A1").Select
ActiveCell.FormulaR1C1 = "1"
Range("B1").Select
Selection.End(xlDown).Select
X1Cell = ActiveCell.Row
Range(Cells(1, 1), Cells(X1Cell, 1)).Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
step:=1, Trend:=False
Range("A1").Select
End Sub
Sub CloneSheet()
'
' CloneSheet Macro
' Macro recorded 11/12/02 by Setiono
'
ActiveSheet.Copy After:=Sheets(Sheets.Count)
End Sub
Sub DelEntireRow()
'
' DelEntireRow Macro
' Macro recorded 11/15/02 by Setiono
'
'
Selection.EntireRow.Delete
End Sub
Sub ClonePOIssuingList()
'
' Macro1 Macro
' Macro recorded 11/14/02 by Setiono
'
V = Range("A24").Value
V = V + 1
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Range("A10:I24").ClearContents
Range("A10").Value = V
Range("A10:A24").Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
step:=1, Trend:=False
ActiveSheet.Name = Range("A10").Value & "-" & Range("A24").Value
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("B10").Select
End Sub
Sub DeleteActiveSheet()
' Macro recorded 11/15/02 by Setiono
'
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End Sub
Sub DateConvert()
'
' Macro1 Macro
' Macro recorded 12/13/02 by Setiono
'
Dim AC As Long, AR As Long, ARE As Long
AC = ActiveCell.Column
AR = ActiveCell.Row
Selection.Cells(Selection.Cells.Count).Select
ARE = ActiveCell.Row
ConvertDate AC, AR, ARE
End Sub
Sub SequenceNo()
'
' Macro3 Macro
' Macro recorded 12/28/02 by Setiono
'
'
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
step:=1, Trend:=False
End Sub
Sub DelRedudantPart()
Dim x As Long, Y As Long
x = ActiveCell.Column
Y = ActiveCell.Row
For n = Y To IsEOF(Y, x)
If Cells(n, x) = Cells(n + 1, x) And Cells(n, x) = Cells(n + 2, x) And Cells(n, x) <> "" Then
Cells(n + 1, x).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Else
If Cells(n, x) = Cells(n + 1, x) And Cells(n, x) <> "" Then
Cells(n + 1, x).ClearContents
End If
End If
Next n
Range("A1").Select
End Sub
Sub Compact_SubTotal()
'
' Macro1 Macro
' Macro recorded 10/26/02 by Setiono
'
Dim Y1Cell As Long, X1Cell As Long, B As Long
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
i = 0
Counter = 0
For Counter = X1Cell To 65536
If Left(Cells(Counter, Y1Cell), 1) = "" Then
i = i + 1
If Left(Cells(Counter + 1, Y1Cell), 1) = "" Then
If Left(Cells(Counter + 2, Y1Cell), 1) = "" Then
EofR = Counter
Exit For
End If
End If
End If
Next
EofR = EofR + i
For n = X1Cell To EofR
If Cells(n, Y1Cell) <> "" Then
V = V + Cells(n, Y1Cell).Value
Else
Cells(n, Y1Cell).Value = V
Cells(n, Y1Cell).Font.Bold = True
Cells(n, Y1Cell).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
V = 0
Rows(n + 1).Select
Selection.Insert Shift:=xlDown
n = n + 1
End If
Next n
'Y1Cell = ActiveCell.Column
'X1Cell = ActiveCell.Row
'EofR = IsEOF(Y1Cell, X1Cell)
B = X1Cell
For n = X1Cell To EofR
If Cells(n, Y1Cell) = "" Then
Cells(n - 1, Y1Cell).Cut
Cells(B, Y1Cell).Select
ActiveSheet.Paste
B = n + 1
End If
Next n
For n = X1Cell + 1 To EofR
Cells(n, Y1Cell).Select
While Cells(n, Y1Cell) <> ""
ActiveCell.EntireRow.Delete
Wend
ActiveCell.EntireRow.Delete
n = n + 1
If Cells(n, Y1Cell) = "" Then Exit For
Next n
Cells(X1Cell, Y1Cell).Select
End Sub
Sub ConvertNo2Date()
'
' ConvertNo2Date Macro
' Macro recorded 2/18/03 by Setiono
'
'
Selection.NumberFormat = "dd-mmm-yy"
End Sub
Sub CombineCells2Left()
'
' CombineCells2Left Macro
' Macro recorded 27/8/03 by Setiono
'
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
Selection.Cells(Selection.Cells.Count).Select
Y1CE = ActiveCell.Column
X1CE = ActiveCell.Row
sw = 0
For n = X1Cell To X1CE
For o = Y1Cell To Y1CE
Cells(n, Y1Cell).Value = Cells(n, Y1Cell).Value & _
Cells(n, o + 1).Value
If sw <> 0 Then Cells(n, o).Value = ""
sw = sw + 1
Next o
Next n
End Sub
Sub CombineCells2LeftWithComma()
'
' CombineCells2Left Macro
' Macro recorded 27/8/03 by Setiono
'
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
Selection.Cells(Selection.Cells.Count).Select
Y1CE = ActiveCell.Column
X1CE = ActiveCell.Row
sw = 0
For n = X1Cell To X1CE
For o = Y1Cell To Y1CE
Cells(n, Y1Cell).Value = Cells(n, Y1Cell).Value & ", " & _
Cells(n, o + 1).Value
If sw <> 0 Then Cells(n, o).Value = ""
sw = sw + 1
Next o
Next n
End Sub
Sub ImportPO()
'
' FormatPO Macro
' Macro recorded 2/19/03 by Setiono
'
Application.DisplayAlerts = False
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF.PO", Origin:=xlWindows, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(16 _
, 1), Array(29, 1), Array(53, 1), Array(62, 1), Array(68, 1), Array(72, 1), Array(85, 1))
Columns("B:B").ColumnWidth = 18.57
Columns("B:B").ColumnWidth = 15.86
Columns("C:C").ColumnWidth = 19.86
Columns("C:C").ColumnWidth = 22.29
ActiveWorkbook.SaveAs FileName:= _
"D:\Documents & Settings\Job\Vendor\1110030 - Sanyo Semiconductor (S) Pte, Ltd\PO LIST\NEW_PO.xls", FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub FormatPO()
'
' Macro7 Macro
' Macro recorded 2/19/03 by Setiono
'
'Delete header other than the first header
'Dim vcode As Long
EofRowC = InputBox("Enter End of Row", "End of Row Usage Confirmation")
For Counter = 1 To EofRowC
If Left(Cells(Counter, 1), 5) = "SANYO" Or Left(Cells(Counter, 1), 2) = "PT" Or _
Left(Cells(Counter, 1), 4) = "PANA" Or Left(Cells(Counter, 1), 3) = "HPC" Or _
Left(Cells(Counter, 1), 4) = "FUJI" Or Left(Cells(Counter, 1), 7) = "SHINDEN" Then
vcode = Right(Cells(Counter + 3, 3), 7)
Cells(Counter + 7, 5).Value = vcode
Counter = Counter - 1
For p = 1 To 8
Cells(Counter, 1).Select
Selection.EntireRow.Delete
Next p
End If
If Left(Cells(Counter, 3), 19) = "* TO BE CONTINUED *" Then
Cells(Counter, 3).Select
Selection.EntireRow.Delete
End If
Next
'Combine Model and Lot from cell A and C and D become A and B
For Counter = 1 To EofRowC
If Cells(Counter, 7).Value = "" And Cells(Counter + 1, 7).Value <> "" Then
Range(Cells(Counter, 2), Cells(Counter, 4)).Select
br = ActiveCell.Row
bc = ActiveCell.Column
Selection.Cells(Selection.Cells.Count).Select
br1 = ActiveCell.Row
bc1 = ActiveCell.Column
For R = br To br1
For c = bc + 1 To bc1
Cells(R, bc).Value = Cells(R, bc).Value & Cells(R, c).Value
Cells(R, c).ClearContents
Next c
Next R
Cells(br, bc).Select
Cells(Counter, 3).Value = Cells(Counter, 5).Value
Cells(Counter, 5).ClearContents
End If
Next Counter
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
For n = 1 To IsEOF(1, 4)
If Cells(n, 4) <> "" And Cells(n, 9) = "" Then
Range(Cells(n, 4), Cells(n, 6)).Select
Selection.Cut Destination:=Range(Cells(n + 1, 1), Cells(n + 1, 3))
End If
Next n
Range("D1").Select
EraseBlankRow
EofCellUsage = IsEOF(1, 4)
If EofCellUsage > 1 Then
Range(Cells(1, 1), Cells(EofCellUsage, 3)).Select
FillBlank
End If
Columns("A:C").Select
ConvertCellsContent2Value
Columns("A:A").NumberFormat = "0000000000"
Rows("1:1").Insert Shift:=xlDown
Range("A1").FormulaR1C1 = "P.O. NO."
Range("B1").FormulaR1C1 = "MODEL/LOT"
Columns("B:B").ColumnWidth = 15.29
Range("C1").FormulaR1C1 = "V. CODE"
Range("D1").FormulaR1C1 = "DLV. DATE"
Columns("D:D").ColumnWidth = 10
Range("E1").FormulaR1C1 = "PART CODE"
Range("F1").FormulaR1C1 = "PART DESCRIPTION"
Range("H1").FormulaR1C1 = "P.O. QTY."
Range("J1").FormulaR1C1 = "PRICE"
Columns("J:J").ColumnWidth = 12.71
Range("K1").FormulaR1C1 = "AMOUNT"
Columns("J:J").Select
Selection.NumberFormat = _
"_($* #,##0.0000_);_($* (#,##0.0000);_($* ""-""????_);_(@_)"
Columns("K:K").Select
Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Columns("G:G").Delete Shift:=xlToLeft
Columns("H:H").Delete Shift:=xlToLeft
Range(Cells(2, 4), Cells(IsEOF(2, 4), 4)).Select
For n = 2 To IsEOF(2, 4)
If Cells(n, 4) <> "" Then
CellTMP = Cells(n, 4).Value
CellTMP = "'" & CellTMP
Cells(n, 4).Select
'Selection.FormulaR1C1 = CellTMP
If Mid(CellTMP, 3, 1) = "/" Then
Selection.Value = _
Mid(CellTMP, 2, 1) & "/" & Right(CellTMP, 2) & "/" & "200" & Mid(CellTMP, 4, 1)
Else
Selection.Value = _
Mid(CellTMP, 2, 2) & "/" & Right(CellTMP, 2) & "/" & "200" & Mid(CellTMP, 5, 1)
End If
'Selection.Value = Mid(CellTMP, 2, 1) & "/" & Right(CellTMP, 2) & "/" & "200" & Mid(CellTMP, 4, 1)
Selection.NumberFormat = "d-mmm-yy"
End If
Next n
Range("A1").Select
End Sub
Sub ImportRollingForcast()
'
' ImportRollingForcast Macro
' Macro recorded 2/21/03 by Setiono
'
Application.DisplayAlerts = False
nm = InputBox("Nama forecast file - tsfsplf.???????", , "forecast")
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF." & nm, Origin:= _
xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, _
1), Array(16, 1), Array(42, 1), Array(47, 1), Array(57, 1), Array(67, 1), Array(77, 1), _
Array(87, 1), Array(97, 1), Array(107, 1))
Columns("A:A").Insert Shift:=xlToRight
For n = 5 To 10
CellTMP = "'" & Cells(6, n)
If Mid(CellTMP, 5, 1) = "/" Then
Cells(6, n).Value = Mid(CellTMP, 4, 1) & "/200" & Right(CellTMP, 1)
Else
Cells(6, n).Value = Mid(CellTMP, 4, 2) & "/200" & Right(CellTMP, 1)
End If
Cells(6, n).NumberFormat = "mmm-yy"
Next n
t = Mid(Cells(5, 3), 13, 7)
Cells(8, 1).Value = t
Cells(5, 1).EntireRow.Delete
Range("b1:c4").ClearContents
Range("d4", "d5").ClearContents
Range("e4").ClearContents
Range("j1:k2").ClearContents
Range("j1").Value = "DAT" & Range("h1").Value & Left(Range("i1").Value, 1)
Range("j2").Value = "DAT" & Range("h2").Value & Left(Range("i2").Value, 1)
Range("g1:i2").ClearContents
Range("d2:f2").Select
CombineCells2Left
Range("A5").Select
ActiveCell.FormulaR1C1 = "V. CODE"
Range("A6").Select
ActiveCell.FormulaR1C1 = "'-----------"
Range("A7").Select
For Counter = 6 To 65536
If Left(Cells(Counter, 2), 8) = "BXA052PA" Then
Counter = Counter - 1
For p = 1 To 4
Cells(Counter + 1, 1).Select
Cells(Counter + 1, 1).EntireRow.Delete
Next p
t = Mid(Cells(Counter + 1, 3), 13, 7)
Cells(Counter + 4, 1).Value = t
Cells(Counter + 1, 1).EntireRow.Delete
Cells(Counter + 1, 1).EntireRow.Delete
Cells(Counter + 1, 1).EntireRow.Delete
End If
Next
Columns("B:B").ColumnWidth = 16#
Columns("C:C").ColumnWidth = 29.57
EndRowUsage = IsEOF(7, 4)
Range(Cells(7, 1), Cells(EndRowUsage, 1)).Select
FillBlank
ActiveWorkbook.SaveAs FileName:= _
"D:\Documents & Settings\Job\Rolling Forecast\Rolling Frocast.xls", FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub SortMDLDummy()
'
' SortMDLDummy Macro
' Macro recorded 3/5/03 by Setiono
'
'
Selection.Sort Key1:=Range("E471"), Order1:=xlAscending, Key2:=Range( _
"F471"), Order2:=xlAscending, Key3:=Range("D471"), Order3:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom
End Sub
Sub MovingPONO2topleftside()
'
' Macro4 Macro
' Macro recorded 3/14/03 by Setiono
'
For n = 5 To 25
If Cells(n, 9).Value <> "" Then
Cells(n - 1, 3).Value = Cells(n, 9).Value
Cells(n - 1, 4).Value = Cells(n, 10).Value
End If
Next n
End Sub
Sub GTotal()
'
' Macro1 Macro
' Macro recorded 10/26/02 by Setiono
'
Dim Y1Cell As Long
Dim X1Cell As Long
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
EofR = IsEOF(X1Cell, Y1Cell)
For n = X1Cell To EofR
If Cells(n, Y1Cell) = "" Then
V = V + Cells(n - 1, Y1Cell).Value
End If
Next n
Cells(n - 1, Y1Cell).Value = V
Cells(n - 1, Y1Cell).Font.Bold = True
Cells(n - 1, Y1Cell).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
Cells(Y1Cell, X1Cell).Select
End Sub
Sub MergeCenter()
'
' MergeCenter Macro
' Macro recorded 3/27/03 by Setiono
'
'
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = True
End With
End Sub
Sub InsertRow()
'
' InsertRow Macro
' Macro recorded 3/14/03 by Setiono
'
'
Selection.EntireRow.Insert
End Sub
Sub ConvertMinus()
Dim Y1Cell As Long, X1Cell As Long
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
For n = X1Cell To IsEOF(Y1Cell, X1Cell)
If Right(Cells(n, Y1Cell), 1) = "-" Then Cells(n, Y1Cell).Value = _
-1 * (Left(Cells(n, Y1Cell), Len(Cells(n, Y1Cell)) - 1))
Next n
Cells(X1Cell, Y1Cell).Select
End Sub
Sub Validate()
Dim Y1Cell As Long, X1Cell As Long, p As Long
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
p = 0#
a = InputBox("Baris Akhir ?")
For n = X1Cell To a 'IsEOF(Y1Cell, X1Cell)
p = Cells(n, Y1Cell).Value
Cells(n, Y1Cell).Value = p
'Cells(n, Y1Cell).Select
Next n
Cells(X1Cell, Y1Cell).Select
' ActiveCell.FormulaR1C1 = "630"
' Range("H16").Select
End Sub
Sub UpdateTVSpec()
'
' UpdateTVSpec Macro
' Macro recorded 5/21/03 by Setiono
'
'
Application.DisplayAlerts = False
Workbooks.Open FileName:= _
"D:\Documents & Settings\Job\Support\SOPIS\TvSpec\TvSpec.csv"
Columns("G:G").ColumnWidth = 10
Columns("F:F").ColumnWidth = 13.14
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "MODEL"
Range("B1").Select
ActiveCell.FormulaR1C1 = "CHASSIS"
Range("C1").Select
ActiveCell.FormulaR1C1 = "SIZE"
Range("D1").Select
ActiveCell.FormulaR1C1 = "DEST."
Range("E1").Select
ActiveCell.FormulaR1C1 = "SYSTEM"
Range("F1").Select
ActiveCell.FormulaR1C1 = "D. ENG INC"
Range("G1").Select
ActiveCell.FormulaR1C1 = "PRD. NO."
Range("G2").Select
Columns("F:F").ColumnWidth = 14.86
ActiveWorkbook.SaveAs FileName:= _
"D:\Documents & Settings\Job\Support\SOPIS\TvSpec\TvSpec.xls", FileFormat:= _
xlExcel9795, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub FormatMDL()
'
' FormatMDL Macro
' Macro recorded 5/23/03 by Setiono
'
'
Application.DisplayAlerts = False
Do
AskName = UCase(InputBox("Input Model Name? (ex: C5SR#305, Must exist TSFSPLF.C5SR#305 in C:\WINDOWS", "File Name Confirmation"))
Loop Until AskName <> ""
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF." & AskName, Origin:= _
xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, _
1), Array(7, 1), Array(13, 1), Array(15, 1), Array(30, 1), Array(34, 1), Array(61, 1), Array _
(64, 1), Array(67, 1), Array(71, 1), Array(73, 1), Array(82, 1), Array(83, 1), Array(85, 1), _
Array(89, 1), Array(105, 1), Array(106, 1), Array(109, 1), Array(117, 1), Array(130, 1))
ActiveWindow.Zoom = 75
Columns("D:D").ColumnWidth = 15.44
Columns("F:F").ColumnWidth = 25.57
Columns("L:L").ColumnWidth = 2.29
Columns("O:O").ColumnWidth = 11.29
Columns("P:P").ColumnWidth = 2.29
Range("A1:K3").Select
Selection.ClearContents
Range("A5").Select
Selection.ClearContents
Range("A4:F4").Select
Selection.Cut Destination:=Range("D4")
Range("D4:I4").Select
br = ActiveCell.Row
bc = ActiveCell.Column
Selection.Cells(Selection.Cells.Count).Select
br1 = ActiveCell.Row
bc1 = ActiveCell.Column
For R = br To br1
For c = bc + 1 To bc1
Cells(R, bc).Value = Cells(R, bc).Value & " " & Cells(R, c).Value
Cells(R, c).ClearContents
Next c
Next R
Columns("A:C").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("C:F").Select
Selection.Delete Shift:=xlToLeft
Columns("D:F").Select
Selection.Delete Shift:=xlToLeft
Columns("E:F").Select
Selection.Delete Shift:=xlToLeft
Range("D1:G5").Select
Selection.ClearContents
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").ColumnWidth = 14.71
Range("A1").Select
ActiveWorkbook.SaveAs FileName:="D:\Documents & Settings\Job\Models\" & AskName & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub CostDownReportMaker()
'Sub CDRTitle()
'
' CDRTitle Macro
' Macro recorded 8/18/2003 by Setiono
'
'
Range("A1").Select
Selection.EntireRow.Insert
Range("L1:M1").Select
Selection.EntireColumn.Delete
Range("K1").Select
ActiveCell.FormulaR1C1 = "Current"
Range("K2").Select
ActiveCell.FormulaR1C1 = "Price"
Range("L2").Select
Selection.EntireColumn.Insert
ActiveCell.FormulaR1C1 = "Amount"
Range("M1").Select
ActiveCell.FormulaR1C1 = "Standard"
Range("M2").Select
ActiveCell.FormulaR1C1 = "Price"
Range("M3").Select
ActiveWindow.Zoom = 75
Range("K1").Select
Selection.EntireColumn.Insert
Range("K2").Select
ActiveCell.FormulaR1C1 = "Total"
Range("O2").Select
ActiveCell.FormulaR1C1 = "Amount"
Rows("1:1").Select
Range("C1").Activate
Selection.Font.Bold = True
Rows("2:2").Select
Range("C2").Activate
With Selection.Font
.Name = "MS Sans Serif"
.Size = 10
End With
Columns("N:O").Cut
Columns("L:L").Insert Shift:=xlToRight
Range("P1").FormulaR1C1 = "Difference"
Range("P2").FormulaR1C1 = "Amount"
Range("Q2").FormulaR1C1 = "%"
Range("R1").FormulaR1C1 = "New"
Range("R2").FormulaR1C1 = "Price"
Range("S2").FormulaR1C1 = "Amount"
Range("T1").FormulaR1C1 = "Difference"
Range("T2").FormulaR1C1 = "Amount"
Range("U2").FormulaR1C1 = "%"
Range("L1:M1").Merge
Range("N1:O1").Merge
Range("P1:Q1").Merge
Range("R1:S1").Merge
Range("T1:U1").Merge
Range("A1:U2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
End With
Range("A1:A2").Merge
Range("B1:B2").Merge
Range("C1:C2").Merge
Range("D1:D2").Merge
Range("E1:E2").Merge
Range("F1:F2").Merge
Range("G1:G2").Merge
Range("H1:H2").Merge
Range("I1:I2").Merge
Range("J1:J2").Merge
Range("K1:K2").Merge
Range("A1:A2").Select
Range("K3").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-6]:RC[-1])"
Range("J4").Select
Selection.End(xlDown).Select
Range("K96").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Range("E3:K96").Select
Range("K96").Activate
Selection.NumberFormat = "#,##0"
Range("K95").Select
Selection.End(xlUp).Select
Range("M3").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]"
Range("L3").Select
Selection.End(xlDown).Select
Range("M96").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Range("L96").Select
Range(Selection, Selection.End(xlUp)).Select
Range("L95").Select
Selection.End(xlUp).Select
Range("L3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="#N/A", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("O3").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-4]"
Range("N3").Select
Range(Selection, Selection.End(xlDown)).Select
Range("N3").Select
Selection.End(xlDown).Select
Range("O96").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Range("O95").Select
Range("M58").Select
Selection.End(xlUp).Select
Range("M3:O3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "#,##0.00"
Range("P3").Select
ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-3]"
Range("O4").Select
Selection.End(xlDown).Select
Range("P96").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Selection.End(xlUp).Select
Range("P3").Select
ActiveCell.FormulaR1C1 = "=RC[-3]-RC[-1]"
Range("O3").Select
Selection.End(xlDown).Select
Range("P96").Select
Range(Selection, Selection.End(xlUp)).Select
Range("P3:P96").Select
Range("P96").Activate
Selection.FillDown
Range("Q96").Select
Selection.End(xlUp).Select
Range("Q3").Select
ActiveCell.FormulaR1C1 = "=RC[-1]/RC[-4]"
Range("P3").Select
Selection.End(xlDown).Select
Range("Q96").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Selection.Style = "Percent"
Selection.NumberFormat = "0.0%"
Selection.NumberFormat = "0.00%"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Replace What:="#DIV/0!", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.End(xlUp).Select
Application.CutCopyMode = False
Columns("P:P").ColumnWidth = 9.57
'End Sub
'Sub CDR1()
'
' CDR2 Macro
' Macro recorded 8/18/2003 by Setiono
'
'
Dim FirstRow As Long, DiffCol As Long, c As Long, n As Long, p As Long
FirstRow = 3
DiffCol = 1
'Remove space on Active Cell Column
Range(Cells(Val(FirstRow), DiffCol), Cells(IsEOF(1, 1), DiffCol)).Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
p = IsEOF(FirstRow, DiffCol)
p = p - 1
FirstRow = FirstRow + 1
c = 0
BeginRow = FirstRow
EndRow = p
n = 0
Range(Cells(1, 1), Cells(1, 13)).Select
With Selection.Font
.Name = "Arial"
.Size = 10
End With
For n = FirstRow To p
If Cells(n, DiffCol) <> Cells(n - 1, DiffCol) Then
c = c + 1
End If
Next n
For n = BeginRow To EndRow + (c * 2)
If Cells(n, DiffCol) <> Cells(n - 1, DiffCol) And Cells(n, DiffCol) <> "" Then
Cells(n, DiffCol).EntireRow.Insert
Cells(n, DiffCol).EntireRow.Insert
'Range(Cells(n, DiffCol), Cells(n+1, 21)).Value = Range(Cells(1, 1), Cells(1, 13)).Value
'format cells into bold style and desire date format
'Range(Cells(n, DiffCol), Cells(n, 13)).Font.Bold = True
'Range(Cells(n, 5), Cells(n, 10)).NumberFormat = "[$-409]mmm-yy;@"
Range(Cells(1, 1), Cells(2, 21)).Copy
Cells(n, DiffCol).PasteSpecial xlPasteAll
'Range(Cells(n, 1), Cells(n, 14)).Borders(xlInsideVertical).LineStyle = xlNone
'Range(Cells(n, 1), Cells(n, 14)).Interior.ColorIndex = xlNone
n = n + 2
End If
Next n
ActiveWindow.Zoom = 75
Columns("A:A").ColumnWidth = 13.43
Columns("B:B").ColumnWidth = 26.43
'End Sub
'Sub CDR2()
'
' CDR Macro
' Macro recorded 8/18/2003 by Setiono
'
'
Application.CutCopyMode = False
Do
AskPeriode = InputBox("Periode ?", "Input Periode Confirmation")
Loop Until AskPeriode <> ""
For n = 1 To 65536
If Cells(n, 1).Value = "VENDOR NO." Then
c = c + 1
'n = n + 1
End If
If Cells(n, 1).Value = "" And Cells(n + 1, 1).Value = "" Then
E = n
Exit For
End If
Next n
For n = 1 To E + (c * 5)
If Cells(n, 1).Value = "VENDOR NO." Then
Cells(n, 1).Select
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Range(Cells(n + 2, 3), Cells(n + 3, 21)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Merge True
End With
Cells(n + 2, 3).FormulaR1C1 = "COSTDOWN REPORT OF " & Cells(n + 8, 2).Value
Cells(n + 3, 3).FormulaR1C1 = "PERIODE " & AskPeriode
Cells(n + 2, 3).Select
With Selection.Font
.Name = "Arial"
.Size = 12
End With
Selection.Font.Bold = True
Cells(n + 3, 3).Font.Bold = True
n = n + 8
End If
Next n
Range("A1:B1").Select
Selection.EntireColumn.Delete
Range("A9").Select
ActiveWindow.DisplayGridlines = False
'End Sub
End Sub
Sub ScheduleMaker_Step_1()
'
' Format1PrdSchd Macro
' Macro recorded 9/16/03 by Setiono
'
'
Application.DisplayAlerts = False
ActiveWindow.Zoom = 75
On Error Resume Next
Do
nm1 = LCase(InputBox("Sanyo Semicon? (Y/T)", "T"))
Loop Until nm1 = "y" Or nm1 = "t"
If nm1 = "t" Then
ActiveWorkbook.SaveAs FileName:= _
"D:\Schedule.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Else
ActiveWorkbook.SaveAs FileName:= _
"D:\Documents & Settings\Job\Vendor\1110030 - Sanyo Semiconductor (S) Pte, Ltd\Micro Controller\Micon's Production Schedule\Schedule.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End If
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
ActiveWindow.FreezePanes = False
Application.CutCopyMode = False
Do
ada = LCase(InputBox("Ada Autofilter? (Y/T)", "Autofilter Remover", "T"))
Loop Until ada = "y" Or ada = "t"
If ada = "y" Then Selection.AutoFilter
Range("B1:E4").ClearContents
Range("F4").ClearContents
Range("U3:AH3").ClearContents
Range("T3").ClearContents
Range("AD2").ClearContents
Columns("C:C").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-NZ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-AA", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-M", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-SA", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-EU", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-WG", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="#", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="$", Replacement:="T", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Columns("H:H").Insert Shift:=xlToRight
Selection.ColumnWidth = 13.14
Range("G7").Select
Columns("H:H").ColumnWidth = 18.43
For n = 7 To 700
If Cells(n, 3).Value = "E" And Left(Cells(n, 4), 4) = "LINE" Then
Cells(n, 3).EntireRow.Delete
Cells(n, 3).EntireRow.Delete
Exit For
Else
While Cells(n, 7).Value = "" And Not (Cells(n, 3).Value = "E" And _
Left(Cells(n, 4), 4) = "LINE") Or Cells(n, 7).Value = "CHASS"
Cells(n, 7).Select
Selection.EntireRow.Delete
Wend
End If
If Cells(n, 3).Value = "E" And Left(Cells(n, 4), 4) = "LINE" Then
Cells(n, 3).EntireRow.Delete
Cells(n, 3).EntireRow.Delete
Exit For
End If
Next n
'******* remove all shape except for 1st Sanyo Logo *********
Do
On Error Resume Next
c = ActiveSheet.Comments.Count
For n = 1 To c
ActiveSheet.Comments(n).Shape.Select
Selection.Delete
Next n
Loop Until c = 0
Do
On Error Resume Next
c = ActiveSheet.Shapes.Count
For n = 2 To c
ActiveSheet.Shapes(n).Delete
Next n
Loop Until c = 1
'***********************************************************
Columns("B:G").Font.Bold = False
Range("F3").Font.Bold = True
'***************Sortir*************************************
Range("AJ5:AJ6").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Font.Bold = True
Selection.Font.ColorIndex = 0
ActiveCell.FormulaR1C1 = "Casing"
wherex = 8 'ActiveCell.Column
wherey = 7 'ActiveCell.Row
Akhirkol = 33
Akhirbrs = IsEOF(7, 2)
For baris = wherey To Akhirbrs
For kolom = wherex To Akhirkol
Cells(baris, kolom + 1).Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False
Cells(baris, kolom + 1).NumberFormat = "0"
Cells(baris, kolom + 1).Value = Cells(baris, kolom + 1).Value
If Cells(baris, kolom + 1) <> "" Then
Cells(baris, wherex).Value = _
Cells(wherey - 1, kolom + 1).Value
Exit For
Else
End If
Next kolom
Cells(baris, 35).FormulaR1C1 = "=SUM(RC[-25]:RC[-1])"
Cells(baris, 36).Value = Cells(baris, 8).Value
Cells(baris, 8).Value = ""
Cells(baris, 36).Select
Selection.NumberFormat = "d-mmm-yy"
Selection.Font.Bold = False
Selection.Font.ColorIndex = 0
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
Next baris
sw = 0
For baris = wherey To Akhirbrs
For kolom = wherex To Akhirkol
If Cells(baris, kolom + 1).Value = "0" Then
Cells(baris, kolom + 1).EntireRow.Delete
sw = 1
If sw = 1 Then
baris = baris - 1
sw = 0
End If
Exit For
End If
Next kolom
Next baris
Akhirbrs = IsEOF(7, 2)
Range(Cells(7, 8), Cells(Akhirbrs, 35)).Select
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
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlDot
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Selection.NumberFormat = 0
Cells.Replace What:="<", Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False
Cells.Replace What:=">", Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False
Range(Cells(7, 2), Cells(Akhirbrs, 36)).Sort _
Key1:=Range("C7"), Order1:=xlAscending, Key2:=Range("D7") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
ActiveWorkbook.Save
'************************* Step 2 *******************************
' Check for Double Model
For n = 7 To IsEOF(7, 3)
If Cells(n, 3).Value = Cells(n - 1, 3).Value And _
Cells(n, 4).Value = Cells(n - 1, 4).Value And _
Cells(n, 5).Value = Cells(n - 1, 5).Value Then
If Cells(n, 36) > Cells(n - 1, 36) Then
Cells(n, 36).Select
Selection.EntireRow.Delete
Else
Cells(n - 1, 36).Select
Selection.EntireRow.Delete
End If
End If
If Cells(n, 3).Value = Cells(n + 1, 3).Value And _
Cells(n, 4).Value = Cells(n + 1, 4).Value And _
Cells(n, 5).Value = Cells(n + 1, 5).Value Then
If Cells(n, 36) > Cells(n + 1, 36) Then
Cells(n, 36).Select
Selection.EntireRow.Delete
Else
Cells(n + 1, 36).Select
Selection.EntireRow.Delete
End If
End If
If Cells(n, 3).Value = Cells(n - 1, 3).Value And _
Cells(n, 4).Value = Cells(n - 1, 4).Value And _
Cells(n, 5).Value <> Cells(n - 1, 5).Value Then
Range(Cells(n, 2), Cells(n - 1, 7)).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
If Cells(n, 3).Value = Cells(n + 1, 3).Value And _
Cells(n, 4).Value = Cells(n + 1, 4).Value And _
Cells(n, 5).Value <> Cells(n + 1, 5).Value Then
Range(Cells(n, 2), Cells(n + 1, 7)).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
Next n
'************************* Step 3 ******************************
'Sort and remove model(s) with 0 Qty
Akhirbrs = IsEOF(7, 2)
Range(Cells(7, 2), Cells(Akhirbrs, 36)).Sort Key1:=Range("E7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For n = 7 To Akhirbrs - 1
While Cells(n, 5).Value < 5 And Cells(n, 5).Value <> ""
Cells(n, 5).EntireRow.Delete
Wend
Next n
Range(Cells(7, 5), Cells(Akhirbrs, 5)).HorizontalAlignment = xlRight
Range("E7").Select
End Sub
Sub ScheduleMaker_Step_2()
'************************** Step 4 *****************************
'make border
Range(Cells(7, 2), Cells(IsEOF(7, 2), 36)).Select
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 = xlDot
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlDot
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'************************************ Step 5 ***********************************************************
'Link to Micon's Models(s)
Do
nm = LCase(InputBox("Sanyo Semicon bukan? Ya/Bukan (Y/B)", "B"))
Loop Until nm = "y" Or nm = "b"
If nm = "b" Then
lm = InputBox("Nama File yang mau dilink untuk model2 nya?")
'fm = InputBox("Nama Folder tempat filenya?")
'Workbooks.Open FileName:=fm & lm
Else
Workbooks.Open FileName:= _
"D:\Documents & Settings\Job\Vendor\1110030 - Sanyo Semiconductor (S) Pte, Ltd\Micro Controller\Micon Models.xls"
End If
Windows("Schedule.xls").Activate
Range("H7").Select
If nm = "b" Then
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-5],'[lm]Sheet1 (2)'!R2C1:R1317C2,2,FALSE)"
Else
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-5],'[Micon Models.xls]Sheet1 (2)'!R2C1:R452C2,2,FALSE)"
End If
Range("G7").Select
Selection.End(xlDown).Select
Y = ActiveCell.Row
Range(Cells(7, 8), Cells(Y, 8)).Select
Selection.FillDown
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range(Cells(7, 2), Cells(IsEOF(7, 2), 36)).Sort _
Key1:=Range("H7"), Order1:=xlAscending, Key2:=Range("AJ7") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
On Error Resume Next
For n = 7 To IsEOF(7, 8)
sw = 0
If Cells(n, 8) = "#N/A" Then
sw = 1
Cells(n, 8).EntireRow.Delete
End If
If sw = 1 Then
n = n - 1
sw = 0
End If
Next n
Application.CutCopyMode = False
ActiveWorkbook.Save
If nm = "b" Then Windows(lm).Close Else Windows("Micon Models.xls").Close
Windows("Schedule.xls").Activate
wherex = 10
wherey = 7
Akhirkol = 34
Akhirbrs = IsEOF(7, 2)
For baris = wherey To Akhirbrs
For kolom = wherex To Akhirkol
If Cells(baris, kolom) <> "" Then
If kolom - 10 < wherex Then
If kolom - 5 < wherex Then
Cells(baris, kolom).Select
With Selection.Interior
.ColorIndex = 7
.Pattern = xlSolid
End With
Else
Cells(baris, kolom - 5).Value = Cells(baris, kolom).Value
Cells(baris, kolom).Value = ""
Cells(baris, kolom).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
Else
Cells(baris, kolom - 9).Value = Cells(baris, kolom).Value
Cells(baris, kolom).Value = ""
Cells(baris, kolom).Select
With Selection.Interior
.ColorIndex = 35
.Pattern = xlSolid
End With
End If
End If
Next kolom
Next baris
E = IsEOF(7, 2)
Range(Cells(7, 2), Cells(E, 36)).Sort _
Key1:=Range("AJ7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range(Cells(7, 8), Cells(E, 36)).Select
With Selection
.Font.Bold = False
.Font.Italic = False
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Name = "Times New Roman"
.Font.Size = 10
End With
Range(Cells(7, 8), Cells(E, 35)).Select
Selection.NumberFormat = "0"
End Sub
Sub Format0526()
Application.DisplayAlerts = False
Do
AskName = UCase(InputBox("Input Model Name? (ex: C5SR#305, Must exist TSFSPLF.C5SR#305 in C:\WINDOWS", "File Name Confirmation"))
Loop Until AskName <> ""
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF." & AskName, Origin:=xlWindows, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(22 _
, 1), Array(52, 1), Array(74, 1), Array(87, 1))
Columns("B:B").ColumnWidth = 20.43
Columns("B:B").ColumnWidth = 17.57
Columns("A:A").ColumnWidth = 16.86
Columns("A:A").ColumnWidth = 13.71
Columns("C:C").ColumnWidth = 16.14
Columns("D:D").ColumnWidth = 16.29
Columns("D:D").ColumnWidth = 11
ActiveWindow.Zoom = 75
Range("A1").Select
ActiveWorkbook.SaveAs FileName:="D:\Documents & Settings\Job\Models\" & AskName & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub FormatModel()
Application.DisplayAlerts = False
Do
AskName = UCase(InputBox("Input Model Name? (ex: C5SR#305, Must exist TSFSPLF.C5SR#305 in C:\WINDOWS", "File Name Confirmation"))
Loop Until AskName <> ""
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF." & AskName, Origin:= _
xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, _
1), Array(7, 1), Array(13, 1), Array(15, 1), Array(30, 1), Array(34, 1), Array(61, 1), Array _
(64, 1), Array(67, 1), Array(71, 1), Array(73, 1), Array(82, 1), Array(83, 1), Array(85, 1), _
Array(89, 1), Array(105, 1), Array(106, 1), Array(109, 1), Array(117, 1), Array(130, 1))
ActiveWindow.Zoom = 75
Range("A1").Select
ActiveWorkbook.SaveAs FileName:="D:\Documents & Settings\Job\Models\" & AskName & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub ImportMonthlyRcv()
'
' ImportMonthlyRcv Macro
' Macro recorded 10/17/03 by Setiono
'
'
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF.MRCV", Origin:=xlWindows, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(10 _
, 1), Array(26, 1), Array(37, 1), Array(46, 1), Array(47, 1), Array(63, 1), Array(81, 1), _
Array(89, 1), Array(106, 1))
End Sub
Sub SortMDLonPRDSCHD()
'posisi cell aktiv menunjukkan posisi awal cell yg akan diisi
wherex = ActiveCell.Column
wherey = ActiveCell.Row
Do
Akhirkol = LCase(InputBox("Masukkan kolom terakhir dari schedule (A=1, B=2, ...)", "Tanya akhir kolom"))
Loop Until Akhirkol <> "" And Akhirkol > 0
Do
Akhirbrs = LCase(InputBox("Masukkan Baris terakhir dari schedule (1, 2, ...)", "Tanya akhir baris"))
Loop Until Akhirbrs <> "" And Akhirbrs > 0
'Do
' BrsTgl = LCase(InputBox("Masukkan baris tanggal dari schedule...", "Tanya baris tanggal"))
'Loop Until BrsTgl <> "" And BrsTgl > 0
For baris = wherey To Akhirbrs
For kolom = wherex To Akhirkol
If Cells(baris, kolom + 1) <> "" Then
Cells(baris, wherex).Value = _
Cells(wherey - 1, kolom + 1).Value
Exit For
Else
End If
Next kolom
Next baris
End Sub
Sub ConvertCellsContent2Value()
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
'********************************************************************************************
'* SUBROUTINE & FUNCTION
'********************************************************************************************
'Sub Header(SortMethod As String)
'****************** Formatting SAPL Delivery Scedule Header ********************
'End Sub
Function IsEOF(Y As Long, x As Long) As Long
'Function to determine Row after End of usage Row
'Can detect All Cell for 3 Row Blank then this function will treat current cell is Eof Row Usage
'Where X = Column and Y = Row
Counter = 0
For Counter = Y To 65536
If IsEmpty(Cells(Counter, x)) Then
If IsEmpty(Cells(Counter + 1, x)) Then
If IsEmpty(Cells(Counter + 2, x)) Then
IsEOF = Counter - 1
Exit For
End If
End If
End If
Next
End Function
Sub ImportDoc(FileName)
Workbooks.OpenText FileName:=FileName, Origin:=xlWindows, StartRow _
:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(15, 1), Array _
(25, 1), Array(41, 1), Array(50, 2), Array(58, 1), Array(70, 1), Array(82, 1), Array(94, 1), _
Array(106, 2), Array(116, 2), Array(125, 1), Array(139, 1), Array(151, 1), Array(159, 1))
End Sub
Sub ConvertDate(ColumnCell As Long, StartCell As Long, EndCell As Long)
'Subrutin to change SOPIS Date format to Excel Format
'ColumnCel is a Column to be process where the date exist
'StartCell is a Row where this subrutin start to convert the date
'EndCell is a Row where this subrutin stop to convert the date
'Created by Setiono October 19, 2002
For n = StartCell To EndCell
If Not IsEmpty(Cells(n, ColumnCell)) Then
CellTMP = "'" & Cells(n, ColumnCell).Value
Cells(n, ColumnCell).Select
If Mid(CellTMP, 4, 1) = "/" Then
Selection.Value = _
Mid(CellTMP, 4, 1) & "/" & Right(CellTMP, 2) & "/" & "200" & Mid(CellTMP, 2, 1)
Else
Selection.Value = _
Mid(CellTMP, 4, 2) & "/" & Right(CellTMP, 2) & "/" & "200" & Mid(CellTMP, 2, 1)
End If
Selection.NumberFormat = "d-mmm-yy"
Cells(n, ColumnCell).Value = Cells(n, ColumnCell).Value 'validate
End If
Next n
End Sub
Sub FillImplosionsMDL()
'
Dim x As Long, Y As Long, E As Long
x = ActiveCell.Column - 5
Y = ActiveCell.Row
E = IsEOF(Y, x)
For n = Y To E
Cells(n, x + 5).FormulaR1C1 = _
"=IF(RC[-1]<>"""",RC[-1],IF(RC[-2]<>"""",RC[-2],RC[-3]))"
Next n
Range(Cells(Y, x + 5), Cells(E, x + 5)).Select
ConvertCellsContent2Value
End Sub
Sub FillDown()
'
' Macro3 Macro
' Macro recorded 1/30/04 by Setiono
'
'
Dim x As Long, Y As Long, E As Long
x = ActiveCell.Column
Y = ActiveCell.Row
E = IsEOF(Y, x)
'MsgBox (E)
Range(Cells(Y, x), Cells(E, x)).Select
Selection.FillDown
ConvertCellsContent2Value
End Sub
Sub LinkPartImplosionsAndTVSpec()
'
' Macro2 Macro
' Macro recorded 1/30/04 by Setiono
'
Application.Run "Personal.xls!UpdateTVSpec"
ActiveWindow.ActivateNext
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],TvSpec.xls!R2C1:R1272C2,2,FALSE)"
Range("E2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],TvSpec.xls!R2C1:R1272C3,3,FALSE)"
Range("F2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],TvSpec.xls!R2C1:R1272C4,4,FALSE)"
Range("C2:C285").Select
Selection.Replace What:="#", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("D2").Select
Application.Run "Personal.xls!FillDown"
Range("E2").Select
Application.Run "Personal.xls!FillDown"
Range("F2").Select
Application.Run "Personal.xls!FillDown"
Windows("TvSpec.xls").Activate
ActiveWindow.Close
Range("C2").Select
End Sub
Sub Move2Right()
'
' Macro5 Macro
' Macro recorded 1/30/04 by Setiono
'
'
x = ActiveCell.Column
Y = ActiveCell.Row
Selection.End(xlDown).Select
Y1 = ActiveCell.Row
X1 = x
For n = Y + 1 To Y1
X1 = X1 + 1
Cells(Y, X1).Value = Cells(n, x)
Next n
End Sub
Sub HPC_PO_Count()
' HPC_PO_Count Macro
t = 0
B = Val(InputBox("Baris awal yang akan diproses, baris ke..."))
E = Val(InputBox("Baris Terakhir yang akan diproses, baris ke..."))
C1 = Val(InputBox("BAL QTY ada di kolom ke..."))
C2 = Val(InputBox("EOF QTY ada di kolom ke..."))
For n = B To E
Cells(n, 8).Select
t = t + Cells(n, C1).Value
If t >= (Cells(n, C2).Value * -1) Then
If Cells(n + 1, 1).Value = Cells(n, 1).Value Then
While Cells(n + 1, 1).Value <> ""
Cells(n + 1, 1).EntireRow.Delete
E = E - 1
Wend
t = 0
n = n + 1
Else
t = 0
n = n + 1
End If
Else
If t < Cells(n, 10).Value Then
If Cells(n + 1, 1).Value <> Cells(n, 1).Value Then
n = n + 1
t = 0
Cells(n, 14).Value = "masalah"
End If
End If
End If
Next
End Sub
Sub Format2Invoice()
'
' Format2Invoice Macro
' Macro recorded 2/11/04 by Setiono
'
Workbooks.Open FileName:= _
"D:\Documents & Settings\Job\Vendor\1110030 - Sanyo Semiconductor (S) Pte, Ltd\PO LIST\PART LIST & PRICE.xls"
ActiveWindow.ActivateNext
Rows("2:8").Delete Shift:=xlUp
Range("I1").Cut Destination:=Range("A1")
Rows("2:5").Insert Shift:=xlDown
Columns("A:A").Insert Shift:=xlToRight
Cells(6, 2).Select
Selection.End(xlDown).Select
Range(Cells(6, 2), Cells(ActiveCell.Row, ActiveCell.Column)).Insert Shift:=xlToRight
Range("B4").Select
ActiveCell.FormulaR1C1 = "INVOICE NO."
Range("C4").Select
ActiveCell.FormulaR1C1 = "PART CODE"
Columns("B:B").ColumnWidth = 12
Columns("C:C").ColumnWidth = 20.43
Columns("E:E").ColumnWidth = 11.14
Columns("H:J").Delete Shift:=xlToLeft
Columns("G:G").Delete Shift:=xlToLeft
Columns("D:D").Insert Shift:=xlToRight
Range("D4").Select
ActiveCell.FormulaR1C1 = "DESCRIPTION"
Columns("H:H").Cut
Columns("E:E").Insert Shift:=xlToRight
Range("E4").Select
ActiveCell.FormulaR1C1 = "QTY"
Columns("F:F").Insert Shift:=xlToRight
Range("F4").Select
ActiveCell.FormulaR1C1 = "PRICE"
Columns("G:G").Insert Shift:=xlToRight
Range("G4").Select
ActiveCell.FormulaR1C1 = "AMOUNT"
Range("H4").Select
ActiveCell.FormulaR1C1 = "MODEL/LOT"
Range("I4").Select
ActiveCell.FormulaR1C1 = "P/O NO."
Range("J4").Select
ActiveCell.FormulaR1C1 = "REMARKS"
Columns("F:F").Insert Shift:=xlToRight
Columns("F:F").ColumnWidth = 2.86
Columns("A:A").ColumnWidth = 1.71
Columns("I:I").ColumnWidth = 11.71
Columns("E:E").ColumnWidth = 7.14
Range("D6").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[PART LIST & PRICE.xls]18-FEB-2003 (2)'!R8C1:R100C2,2,FALSE)"
Cells(6, 3).Select
Selection.End(xlDown).Select
Range(Cells(6, 4), Cells(ActiveCell.Row, 4)).FillDown
Range("G6").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-4],'[PART LIST & PRICE.xls]18-FEB-2003 (2)'!R8C1:R100C3,3,FALSE)"
Range("G6").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-4],'[PART LIST & PRICE.xls]18-FEB-2003 (2)'!R8C1:R100C3,3,FALSE)"
Range("G6").Select
Selection.NumberFormat = "#,##0.0000"
Range("E6:E364").Select
Selection.End(xlDown).Select
Range("G6:G364").Select
Range("G364").Activate
Selection.FillDown
Selection.End(xlUp).Select
Range("H6").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-3]"
Range("G6:G364").Select
Selection.End(xlDown).Select
Range("H6:H364").Select
Range("H364").Activate
Selection.FillDown
Selection.NumberFormat = "#,##0.00"
Sheets("Tsfsplf").Name = "Sheet1"
ActiveWorkbook.Save
Range("A1").Select
End Sub
Sub Split_Number_fr_Text()
'
' Split_Number_fr_Text Macro
' Macro recorded 12/6/2006 by sanyo
'
For c = 1 To 65535
If Cells(c, ActiveCell.Column) = "" Then Exit For
Next c
a = 0
a = Val(InputBox("Hasilnya taro di kolom berapa?"))
For x = 1 To c
brs = ActiveCell.Row
kol = ActiveCell.Column
kal = Cells(brs, kol)
n = Len(Cells(brs, kol))
kal_n = ""
kal_text = ""
For L = 1 To n
kal_n = Mid(kal, L, 1)
Select Case kal_n
Case 0 To 9
kal_text = Left(kal, L - 2)
Exit For
Case Else
End Select
Next L
Cells(brs, a) = kal_text
brs = brs + 1
kal_text = ""
Cells(brs, kol).Select
Next x
'
End Sub
Sub ClearSpace()
'
' ClearSpace Macro
'
'
Selection.End(xlDown).Select
Y = ActiveCell.Row
x = ActiveCell.Column
For n = 1 To Y
t = Trim(Cells(n, x).Value)
Cells(n, x).Value = t
Next n
End Sub
Sub LinkPlanningSched2DLVSCHD()
'
' Macro5 Macro
'
Dim tgl As String
'On Error Resume Next
'tgl = Format(DateSerial(Year(Now()), Month(Now()), Day(Now())), "dd-mmm-yy")
For n = 1 To 65000
If Cells(n, 5) <> "" Then
Cells(n, 8).Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-4],'[DLVSCH_1110460_03-Jun-09.xls]FINAL'!R2C1:R3720C12,12,FALSE)"
ActiveCell.Select
Selection.NumberFormat = "[$-409]d-mmm-yy;@"
Cells(n, 9).Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-5],'[DLVSCH_1110460_03-Jun-09.xls]FINAL'!R2C1:R3720C11,11,FALSE)"
ActiveCell.Select
Selection.NumberFormat = "General"
Cells(n, 10).Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-6],'[DLVSCH_1110460_03-Jun-09.xls]FINAL'!R2C1:R3720C19,19,FALSE)"
ActiveCell.Select
Selection.NumberFormat = "General"
End If
Next n
End Sub
Sub SplitDifferentMonth()
'
' Split Diffrent Item Macro base on ActiveCell Position
' Macro recorded 10/9/02 by Setiono
'
'
Dim Y1Cell As Long, X1Cell As Long
X1Cell = ActiveCell.Column
Y1Cell = ActiveCell.Row
SplitMonth Y1Cell, X1Cell
End Sub
Sub SplitMonth(FirstRow As Long, DiffCol As Long)
'Remove space on Active Cell Column
p = IsEOF(FirstRow, DiffCol)
Range(Cells(FirstRow, DiffCol), Cells(p, DiffCol)).Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
FirstRow = FirstRow + 1
For n = FirstRow To p
If Month(Cells(n, DiffCol)) <> Month(Cells(n - 1, DiffCol)) Then
c = c + 1
End If
Next n
For n = FirstRow To p + c
If Month(Cells(n, DiffCol)) <> Month(Cells(n - 1, DiffCol)) Then
Cells(n, DiffCol).EntireRow.Insert
'Rows(n).RowHeight = 10
'Range(Cells(n, 1), Cells(n, 14)).Borders(xlInsideVertical).LineStyle = xlNone
'Range(Cells(n, 1), Cells(n, 14)).Interior.ColorIndex = xlNone
n = n + 1
End If
Next n
End Sub
Sub EraseColG()
For n = 7 To 745
Cells(n, 7).Select
If Cells(n, 7).Value = "---" Or Cells(n, 7).Value = "" Or Cells(n, 7).Value = "___" Then
While Cells(n, 7).Value = "---" Or Cells(n, 7).Value = "" Or Cells(n, 7).Value = "___"
Cells(n, 7).EntireRow.Delete
Wend
End If
Next
End Sub
Sub TransPosePaste()
'
' TransPosePaste Macro
'
'
Range("J6:L7").Select
Selection.Copy
Range("A15").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
' Schedule_Calculator Macro
' Macro recorded 12/16/03 by Setiono
'
Dim E As Integer, kolom As Byte, baris As Integer, MICON As String, Q(10) As Integer
Dim QP(10) As String, n As Byte
E = IsEOF(7, 8)
For n = 1 To 10
Q(n) = 0
Next n
QP(1) = "QXXAVC016---N / IC LC863356B-50P7"
QP(2) = "QXXAVC042---P / IC LC863440W-50E5-TLM"
QP(3) = "QXXAVC044---P / IC LC863440W-50K0-TLM"
QP(4) = "QXXAVC129---P / IC LC863440W-51C2-TLM"
QP(5) = "QXXAVC214A--P / IC LC863440W-52Z8-TLM"
QP(6) = "QXXAVC274---P / IC LC863440W-51T8-TLM"
QP(7) = "QXXAVC305---P / IC LC863448W-52F1-TLM"
QP(8) = "QXXAVC320---P / IC LC863440W-52F2-TLM"
QP(9) = "QXXAVC321---P / IC LC863440W-52F3-TLM"
QP(10) = "QXXAVC410---N / IC ST92195C8B1/MCY"
For n = 1 To 10
Cells(E + n, 2).Value = QP(n)
Next n
For kolom = 10 To 34
For baris = 7 To E
MICON = Cells(baris, 8).Value
Select Case MICON ' Evaluate MICON.
Case "QXXAVC016---N"
Q(1) = Q(1) + Cells(baris, kolom).Value
Case "QXXAVC042---P"
Q(2) = Q(2) + Cells(baris, kolom).Value
Case "QXXAVC044---P"
Q(3) = Q(3) + Cells(baris, kolom).Value
Case "QXXAVC129---P"
Q(4) = Q(4) + Cells(baris, kolom).Value
Case "QXXAVC214A--P"
Q(5) = Q(5) + Cells(baris, kolom).Value
Case "QXXAVC274---P"
Q(6) = Q(6) + Cells(baris, kolom).Value
Case "QXXAVC305---P"
Q(7) = Q(7) + Cells(baris, kolom).Value
Case "QXXAVC320---P"
Q(8) = Q(8) + Cells(baris, kolom).Value
Case "QXXAVC321---P"
Q(9) = Q(9) + Cells(baris, kolom).Value
Case "QXXAVC410---N"
Q(10) = Q(10) + Cells(baris, kolom).Value
Case Else
MsgBox "Part tidak dikenal atau mengandung spasi : " & MICON
End Select
Next baris
For n = 1 To 10
With Cells(baris + n - 1, kolom)
.Font.Bold = False
.NumberFormat = "#,##0"
.Value = Q(n)
End With
Next n
For n = 1 To 10
Q(n) = 0
Next n
Next kolom
For n = 1 To 10
Cells(E + n, 35).FormulaR1C1 = "=SUM(RC[-25]:RC[-1])"
Cells(E + n, 35).NumberFormat = "#,##0"
Next n
For n = 1 To 50
If Cells(E + n, 35).Value > 0 Then
Cells(E + n + 1, 2).Select
For n0 = 1 To 4
Selection.EntireRow.Insert
Next n0
Cells(E + n + 1, 3).Value = "REQUEST"
Cells(E + n + 2, 3).Value = "STOCK + REQUEST - " & Left(Cells(E + n, 2).Value, 13) & " PROD. REQUIREMENT"
Cells(E + n + 3, 3).Value = "DELIVERY"
Cells(E + n + 4, 3).Value = "STOCK + DELIVERY - " & Left(Cells(E + n, 2).Value, 13) & " PROD. REQUIREMENT"
Cells(E + n + 2, 10).FormulaR1C1 = "=RC[-1]+R[-1]C-R[-2]C"
Range(Cells(E + n + 2, 10), Cells(E + n + 2, 34)).FillRight
Cells(E + n + 4, 10).FormulaR1C1 = "=RC[-1]+R[-1]C-R[-4]C"
Range(Cells(E + n + 4, 10), Cells(E + n + 4, 34)).FillRight
End If
Next n
Range(Cells(E + 1, 2), Cells(E + 50, 36)).Select
With Selection
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).LineStyle = xlNone
End With
Range(Cells(E + 1, 7), Cells(E + 50, 36)).Select
With Selection
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideVertical).Weight = xlThin
End With
End Sub
'*********************************** EOF ************************************************
Sub Hybrid_DlvSchedule()
'
' Macro created 10/16/02 by Setiono
'
Dim E As Long, SortKey As String, fname As Variant, bln(12) As String
Dim MyDate
bln(1) = "Jan": bln(2) = "Feb": bln(3) = "Mar": bln(4) = "Apr": bln(5) = "May"
bln(6) = "Jun": bln(7) = "Jul": bln(8) = "Aug": bln(9) = "Sep": bln(10) = "Oct"
bln(11) = "Nov": bln(12) = "Dec"
Application.DisplayAlerts = False
Workbooks.Open FileName:="C:\Documents and Settings\Kristina\My Documents\WORKING DAYS.xls"
ImportDoc "C:\Documents and Settings\Kristina\My Documents\TSFSPLF.P1" 'Plant 1
ActiveWindow.Zoom = 75
VNAME = Cells(4, 2).Value & Cells(4, 3).Value
sdate = Cells(1, 9).Value & Cells(1, 10).Value
bulan = Mid(sdate, 11, 2)
tgl = Mid(sdate, 14, 2)
thn = "200" & Mid(sdate, 9, 1)
fname = VNAME & " - (" & tgl & "-" & bln(Val(bulan)) & "-" & thn & ")"
Do
SortKey = LCase(InputBox("Mau diurut base on apa? Part, Production ato Date ? (Part,Prod,Date)", "Sort Order Confirmation", "Part"))
If SortKey = "" Then Exit Sub
Loop Until SortKey = "part" Or SortKey = "prod" Or SortKey = "date"
Do
Ask = LCase(InputBox("Process Plant X ? (Y/N)", "Plant X Progress Confirmation", "N"))
If Ask = "" Then Exit Sub
Loop Until Ask = "n" Or Ask = "y"
If Ask = "y" Then
ImportDoc "C:\Documents and Settings\Kristina\My Documents\TSFSPLF.PX" 'Plant X
E = IsEOF(9, 1)
Range(Cells(1, 1), Cells(E, 15)).Copy 'Copy Data in TSFSPLF.PX
Windows("TSFSPLF.P1").Activate
E = IsEOF(9, 1) 'Determine Eof Row Usage in TSFSPLS.P1
Cells(E + 1, 1).Select
ActiveSheet.Paste
ActiveSheet.Copy 'Clone the Worksheet
Windows("TSFSPLF.PX").Close
Windows("TSFSPLF.P1").Close
End If
Range("A1:C2").ClearContents 'delete "B1AF30 SYS:INSEIA SOPIS & JOB:...
Range("I1:M1").ClearContents 'PROCESS DATE FROM SOPIS (SUBMITTED DATE)
Range("I1").FormulaR1C1 = "DATE: " & tgl & "-" & bln(Val(bulan)) & "-" & thn
CellTMP = Cells(2, 9).Value & Left(Cells(2, 10), 4) 'PROCESS TIME FROM SOPIS (SUBMITTED TIME)
Range("I2:M2").ClearContents
Range("I2").FormulaR1C1 = CellTMP
Range("D2:G2").ClearContents
Range("D2").FormulaR1C1 = "DELIVERY SCHEDULE LIST BY " & UCase(SortKey)
CellTMP = Cells(4, 1).Value & Cells(4, 2).Value & Cells(4, 3).Value
VC = Left(CellTMP, 15)
VN = Right(CellTMP, Len(CellTMP) - 15)
Range("A4:G4").ClearContents
Range("A4").FormulaR1C1 = VC & " " & VN
CellTMP = Cells(5, 1).Value & Cells(5, 2).Value & Cells(5, 3).Value
Range("A5:G5").ClearContents
Range("A5").FormulaR1C1 = CellTMP
'************************** Eof Formatting Header ****************************
XEndCell = IsEOF(1, 1)
Columns("A:A").ColumnWidth = 15
Columns("B:B").ColumnWidth = 10.29
Columns("C:C").ColumnWidth = 16.43
Columns("E:E").ColumnWidth = 10.29
Columns("K:K").ColumnWidth = 9.86
Columns("L:O").Delete Shift:=xlToLeft
Range("A1").Select
For n = 9 To XEndCell
If Left(Cells(n, 2), 1) <> "X" Then
Cells(n, 2).NumberFormat = "0000000000"
End If
If Cells(n, 10).Value = "0/00/00" Then Cells(n, 10).Value = "" 'Delete ANSWER Column if only 0/00/00
If Left(Cells(n, 1), 6) = "B1AF30" Then
For p = 1 To 8
Cells(n, 1).EntireRow.Delete
Next p
n = n - 1
End If
Next n
E = IsEOF(9, 1)
ConvertDate 5, 9, E
ConvertDate 11, 9, E
Do
Ask2 = LCase(InputBox("Di-adjust gak delivery Date-nya ? (Y/T)", "Konfirmasi adjust tuk delivery date", "T"))
If Ask2 = "" Then Exit Sub
Loop Until Ask2 = "t" Or Ask2 = "y"
If Ask2 = "y" Then
MyDate = #4/1/2002# 'BEGIN DATE OF WORKING DAYS
Columns("L:L").ColumnWidth = 15
Range("L7").Value = "SOPIS DLVDATE"
Range("L8").Value = "-------------------------"
TDate = InputBox("Masukin throwing day-nya:", "Konfirmasi Throwing Day", 3)
Do
Ask = LCase(InputBox("Di-Bold gak kalo ada perubahan dlv date? (Y/T)", "Bold konfirmasi", "T"))
If Ask = "" Then Exit Sub
Loop Until Ask = "y" Or Ask = "t"
For n = 9 To E
Cells(n, 12).Value = Cells(n, 5).Value
Cells(n, 12).NumberFormat = "d-mmm-yy"
If IsEmpty(Cells(n, 11)) Then
Else
If Cells(n, 11).Value < MyDate Then
MsgBox "Delivery date diluar jangkauan"
Else
Cells(n, 13).FormulaR1C1 = "=VLOOKUP(RC[-2],'[WORKING DAYS.xls]Sheet1'!R4C2:R557C3,2,FALSE)"
ConvertCellsContent2Value
On Error Resume Next
Cells(n, 13).Value = Cells(n, 13) - TDate
Cells(n, 5).Select
Selection.FormulaR1C1 = "=VLOOKUP(RC[8],'[WORKING DAYS.xls]Sheet1'!R4C3:R557C4,2,FALSE)"
ConvertCellsContent2Value
Cells(n, 13).ClearContents
End If
End If
If Ask = "y" Then If Cells(n, 5) <> Cells(n, 12) Then Cells(n, 5).Font.Bold = True
Next n
End If
If SortKey = "part" Then
Range("A9:L9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("C9"), Order1:=xlAscending, Key2:=Range("E9") _
, Order2:=xlAscending, Key3:=Range("B9"), Order3:=xlAscending
Range("C7").Select
Range(Selection, Selection.End(xlDown)).Cut
Range("A7").Select
Selection.Insert Shift:=xlToRight
Range("B7").Select
Range(Selection, Selection.End(xlDown)).Cut
Range("D7").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
Range("C7").Select
Range(Selection, Selection.End(xlDown)).Cut
Range("B7").Select
Selection.Insert Shift:=xlToRight
Else
If SortKey = "prod" Then
Range("A9:L9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("A9"), Order1:=xlAscending, Key2:=Range("E9") _
, Order2:=xlAscending, Key3:=Range("C9"), Order3:=xlAscending
Else
Range("A9:L9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("E9"), Order1:=xlAscending
End If
End If
Do
Ask = LCase(InputBox("Split Different " & SortKey & " ? (Y/T)", "Split Confirmation", "T"))
If Ask = "" Then Exit Sub
Loop Until Ask = "y" Or Ask = "t"
If Ask = "y" Then If SortKey = "part" Or SortKey = "prod" Then SplitEngine 9, 1 Else SplitEngine 9, 5
Windows("WORKING DAYS.xls").Activate
ActiveWindow.Close
If Not SortKey = "date" Then
Do
Ask = LCase(InputBox("Hapus pengulangan penulisan " & UCase(SortKey) & "? (Y/T)", "Redundant Delete Confirmation", "T"))
If Ask = "" Then Exit Sub
Loop Until Ask = "y" Or Ask = "t"
End If
If Ask = "y" Then
For n = 9 To IsEOF(1, 1)
If Cells(n, 1) = Cells(n + 1, 1) And Cells(n, 1) = Cells(n + 2, 1) And Cells(n, 1) <> "" Then
Cells(n + 1, 1).Select
Range(Selection, Selection.End(xlDown)).ClearContents
Else
If Cells(n, 1) = Cells(n + 1, 1) And Cells(n, 1) <> "" Then Cells(n + 1, 1).ClearContents
End If
Next n
End If
Range("A1").Select
ActiveWorkbook.SaveAs FileName:="C:\Documents and Settings\Kristina\My Documents\DLVSCHED - " & fname & ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub CheckDoubleMDL_in_PRDSched()
For n = 7 To IsEOF(7, 3)
If Cells(n, 3).Value = Cells(n - 1, 3).Value And _
Cells(n, 4).Value = Cells(n - 1, 4).Value And _
Cells(n, 5).Value = Cells(n - 1, 5).Value Then
Range(Cells(n, 2), Cells(n - 1, 7)).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
If Cells(n, 3).Value = Cells(n + 1, 3).Value And _
Cells(n, 4).Value = Cells(n + 1, 4).Value And _
Cells(n, 5).Value = Cells(n + 1, 5).Value Then
Range(Cells(n, 2), Cells(n + 1, 7)).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
Next
End Sub
Sub CombineWorkbooks()
Dim FilesToOpen
Dim x As Integer
On Error GoTo ErrHandler
Application.ScreenUpdating = False
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
MultiSelect:=True, Title:="Files to Merge")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
While x <= UBound(FilesToOpen)
Workbooks.Open FileName:=FilesToOpen(x)
If x <> 1 Then
Sheets().Copy After:=ThisWorkbook.Sheets _
(ThisWorkbook.Sheets.Count)
End If
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
Sub FormatSAPLSubmittedDlvSchedule()
'
' Macro built 10/4/2002 by Setiono
'
'
Dim swD As Long
Do
Ask = UCase(InputBox("Update Menu No. 7 ? (Y/N)", "Menu 97 Update confirmation", "N"))
Loop Until Ask = "Y" Or Ask = "N"
If Ask = "Y" Then FormatMenuNo7 Else Workbooks.Open FileName:= _
"D:\Menu No 7\Menu07.xls"
Workbooks.Open FileName:= _
"C:\My Documents\WORKING DAYS.xls"
swD = 0
Do
AskDate = LCase(InputBox("Does your Excel have problem with Date Conversion ? (Y/N)", "Date Conversion Problem Confirmation", "N"))
Loop Until AskDate = "n" Or AskDate = "y"
If AskDate = "y" Then swD = 1 Else swD = 0
'******** Import Document *************
ImportDoc "C:\WINDOWS\TSFSPLF.P1"
ImportDoc "C:\WINDOWS\TSFSPLF.PX"
'******** Determine Eof Row Usage in TSFSPLS.PX*****************
Dim p, P1, PX, XEndCell As Long
PX = IsEOF(1, 1)
'******** Make Application Move Silent **************
Application.DisplayAlerts = False
'******** Copy Data in TSFSPLF.PX ***************
Range(Cells(1, 1), Cells(PX, 15)).Copy
Windows("TSFSPLF.P1").Activate
'******** Determine Eof Row Usage in TSFSPLS.P1*****************
P1 = IsEOF(1, 1)
' Determine Cell to paste a copy
Cells(P1, 1).Select
ActiveSheet.Paste
'Clone the Worksheet
ActiveSheet.Select
ActiveSheet.Copy
Columns("A:A").ColumnWidth = 16
Columns("B:B").ColumnWidth = 10.57
Columns("C:C").ColumnWidth = 16
Windows("TSFSPLF.PX").Close
Windows("TSFSPLF.P1").Close
'****************** Formatting SAPL Delivery Scedule Header ********************
Range("H4").FormulaR1C1 = "=CONCATENATE(RC[-7],"" "",RC[-6])"
Range("H4").Select
ConvertCellsContent2Value 'Convert Formulas to Value on Active Cells
Range("A4:G4").Delete Shift:=xlToLeft
Range("H5").FormulaR1C1 = "=CONCATENATE(RC[-7],RC[-6],RC[-5])"
Range("H5").Select
ConvertCellsContent2Value 'Convert Formulas to Value on Active Cells
Range("A5:G5").Delete Shift:=xlToLeft
Range("H1").FormulaR1C1 = "=CONCATENATE(RC[1],LEFT(RC[2],4))"
Range("H1").Select
ConvertCellsContent2Value
Range("I1:M1").ClearContents
Range("H1").Cut Destination:=Range("K4")
Range("H2").FormulaR1C1 = "=CONCATENATE(RC[1],LEFT(RC[2],4))"
Range("H2").Select
ConvertCellsContent2Value
Range("I2:M2").ClearContents
Range("H2").Cut Destination:=Range("K5")
Rows("1:3").Delete Shift:=xlUp
'Make All Part Code Position in Column C to Left side
Columns("C:C").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With
Range("a1").Select
'************************** Eof Formatting Header ****************************
For Counter = 9 To 65536
If Left(Cells(Counter, 1), 6) = "B1AF30" Then
Counter = Counter - 1
For p = 1 To 8
Cells(Counter + 1, 1).EntireRow.Delete
Next p
End If
Next
'******* Determine Eof Usage Row Cell ********
XEndCell = IsEOF(1, 1)
'*********************************************
ConvertDate 5, 6, XEndCell
Columns("E:E").NumberFormat = "d-mmm-yy"
Columns("D:D").Delete Shift:=xlToLeft
Columns("F:F").Delete Shift:=xlToLeft
Columns("H:H").Delete Shift:=xlToLeft
Columns("I:K").Delete Shift:=xlToLeft
Columns("H:H").ColumnWidth = 10
ConvertDate 8, 6, XEndCell
Columns("H:H").NumberFormat = "d-mmm-yy"
Application.CutCopyMode = False
Range("A6", Cells(P1, 9)).Sort Key1:=Range("C6"), Order1:=xlAscending, Key2:=Range("D6") _
, Order2:=xlAscending, Key3:=Range("A6"), Order3:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("J4").FormulaR1C1 = "ISSUING"
Range("J5").FormulaR1C1 = "----------------"
For n = 6 To XEndCell - 1
Cells(n, 10).FormulaR1C1 = "=VLOOKUP(RC[-7],[Menu07.xls]MenuNo7!R2C1:R2824C4,2,FALSE)"
Next n
Columns("J:J").NumberFormat = "d-mmm-yy"
Range(Cells(6, 10), Cells(XEndCell, 10)).Select
ConvertCellsContent2Value
On Error Resume Next
For n = 6 To XEndCell - 1
If Cells(n, 10).Value = "#N/A" Then Cells(n, 10).Value = ""
Next n
Range("A1").Select
'Delete those on theway delivery with no balance
p = 0
For n = 6 To IsEOF(1, 1)
If (Cells(n, 9) = Cells(n, 7)) And (Cells(n, 6) = 0) Then p = p + 1
Next n
For n = 6 To IsEOF(1, 1) - p
If (Cells(n, 9) = Cells(n, 7)) And (Cells(n, 6) = 0) Then
While (Cells(n, 9) = Cells(n, 7)) And (Cells(n, 6) = 0)
Cells(n, 7).EntireRow.Delete
Wend
End If
Next n
Columns("K:K").ColumnWidth = 8.29
Range("K4").Value = "PRB CHK"
Range("K5").Value = "---------"
CurrentDate = Date '+2
SaveDate = 14
Range("L6").Value = CurrentDate '#10/21/2002#
Range("L7").Select
Selection.FormulaR1C1 = _
"=VLOOKUP(R[-1]C,'[WORKING DAYS.xls]Sheet1'!R4C2:R557C3,2,FALSE)"
ConvertCellsContent2Value
Range("L8").Value = Range("L7").Value + SaveDate
Range("L9").Select
Selection.FormulaR1C1 = _
"=VLOOKUP(R[-1]C,'[WORKING DAYS.xls]Sheet1'!R4C3:R557C4,2,FALSE)"
Range("L6").NumberFormat = "d-mmm-yy"
Range("L9").NumberFormat = "d-mmm-yy"
ConvertCellsContent2Value
For n = 6 To IsEOF(1, 1)
If Cells(n, 10) <> "" Then
Cells(n, 11).FormulaR1C1 = "=IF(RC[-1]<R9C[1],""Problem"","""")"
Cells(n, 11).Font.Bold = True
End If
Next n
Columns(11).Select
ConvertCellsContent2Value
Range("J1").Value = "DATE CREATED : "
Range("J2").Value = "DATE COMPARED: "
Range("L1") = Range("L6")
Range("L2") = Range("L9")
Range("l1:l2").Select
Selection.NumberFormat = "d-mmm-yy"
ConvertCellsContent2Value
Range("L6:L9").ClearContents
Range("A6:K6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("K9"), Order1:=xlDescending, Key2:=Range("C9") _
, Order2:=xlAscending, Key3:=Range("D9"), Order3:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("C4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range("A4").Select
Selection.Insert Shift:=xlToRight
Range("B4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range("D4").Select
Selection.Insert Shift:=xlToRight
SplitEngine 6, 1
For n = 6 To IsEOF(1, 1)
If Cells(n, 1) = Cells(n + 1, 1) And Cells(n, 1) = Cells(n + 2, 1) And Cells(n, 1) <> "" Then
Cells(n + 1, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Else
If Cells(n, 1) = Cells(n + 1, 1) And Cells(n, 1) <> "" Then
Cells(n + 1, 1).ClearContents
End If
End If
Next n
Range("A1").Select
'************ Saving WorkMook *******************
ActiveWorkbook.SaveAs FileName:= _
"D:\VENDOR_OS.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Windows("Menu07.xls").Close
Windows("WORKING DAYS.xls").Close
Application.DisplayAlerts = True
End Sub
Sub FormatMenuNo7()
'
' FormatMenuNo7 Macro
' Macro recorded 10/8/02 by Setiono
'
Dim Counter As Long
Application.DisplayAlerts = False
Workbooks.Open FileName:="D:\Menu No 7\MenuNo7"
'******* Make Copy *******************
ActiveSheet.Select
ActiveSheet.Copy
YCell = ActiveCell.Column 'Save Active Cell Position
XCell = ActiveCell.Row
'******* Determine Eof Usage Row Cell ********
XEndCell = IsEOF(1, 1)
'*********************************************
Columns("A:A").Delete Shift:=xlToLeft
Columns("B:B").Insert Shift:=xlToRight
Range("B2").FormulaR1C1 = "=DATE(RC[1],RC[2],RC[3])"
Range("B2", Cells(XEndCell - 1, 2)).Select
Selection.FillDown
Selection.NumberFormat = "dd-mmm-yy"
ConvertCellsContent2Value
Range("C:G,J:W").Delete Shift:=xlToLeft
Columns("A:A").ColumnWidth = 15.57
Columns("B:B").ColumnWidth = 9
Columns("C:C").ColumnWidth = 9
Columns("D:D").ColumnWidth = 11.86
n = 0
p = 0
On Error Resume Next ' Defer error handling.
For n = 2 To XEndCell
If Left(Cells(n, 2), 5) = "#NUM!" Then p = p + 1
Next n
For n = 2 To XEndCell - p
If Left(Cells(n, 2), 5) = "#NUM!" Then
While Left(Cells(n, 2), 5) = "#NUM!"
Cells(n, 2).Select
Selection.EntireRow.Delete
Wend
End If
'Validate Data In Column A and Put Result To Column E
Cells(n, 5) = Cells(n, 1).Value
Next
'Replace Data In Column A With Data In Column E
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Cut
Range("A2").Select
ActiveSheet.Paste
'Make Data Alignment to Left Side
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With
Range("A1").FormulaR1C1 = "PART CODE"
Range("B1").FormulaR1C1 = "ISSUING"
Range("C1").FormulaR1C1 = "BALANCE"
Range("D1").FormulaR1C1 = "PROD#"
'Old Active Cell Select
Cells(XCell, YCell).Select
Windows("MenuNo7").Close
'********************* Saving Document *******************
ActiveWorkbook.SaveAs FileName:= _
"D:\Menu No 7\Menu07.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'*********************************************************
Application.DisplayAlerts = True
End Sub
Sub SplitDifferentItem()
'
' Split Diffrent Item Macro base on ActiveCell Position
' Macro recorded 10/9/02 by Setiono
'
'
Dim Y1Cell As Long, X1Cell As Long
X1Cell = ActiveCell.Column
Y1Cell = ActiveCell.Row
SplitEngine Y1Cell, X1Cell
End Sub
Sub SplitEngine(FirstRow As Long, DiffCol As Long)
'Remove space on Active Cell Column
p = IsEOF(FirstRow, DiffCol)
Range(Cells(FirstRow, DiffCol), Cells(p, DiffCol)).Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
FirstRow = FirstRow + 1
For n = FirstRow To p
If Cells(n, DiffCol) <> Cells(n - 1, DiffCol) Then
c = c + 1
End If
Next n
For n = FirstRow To p + c
If Cells(n, DiffCol) <> Cells(n - 1, DiffCol) Then
Cells(n, DiffCol).EntireRow.Insert
'Rows(n).RowHeight = 10
'Range(Cells(n, 1), Cells(n, 14)).Borders(xlInsideVertical).LineStyle = xlNone
'Range(Cells(n, 1), Cells(n, 14)).Interior.ColorIndex = xlNone
n = n + 1
End If
Next n
End Sub
Sub IncByPercent()
'
' Macro1 Macro
' Macro recorded 7/18/03 by Setiono
'
'
Dim p As Long
br = ActiveCell.Row
bc = ActiveCell.Column
Selection.Cells(Selection.Cells.Count).Select
br1 = ActiveCell.Row
bc1 = ActiveCell.Column
Do
p = UCase(InputBox("Increase by How Many Percent (%)?", "Percent confirmation"))
Loop Until p <> 0
For R = br To br1
For c = bc To bc1
If Cells(R, c).Value <> "" Then
Cells(R, c).Value = Cells(R, c).Value * (1 + (p / 100))
End If
Next c
Next R
End Sub
Sub DecByPercent()
'
' Macro1 Macro
' Macro recorded 7/18/03 by Setiono
'
'
Dim p As Long
br = ActiveCell.Row
bc = ActiveCell.Column
Selection.Cells(Selection.Cells.Count).Select
br1 = ActiveCell.Row
bc1 = ActiveCell.Column
Do
p = UCase(InputBox("Decrease by How Many Percent (%)?", "Percent confirmation"))
Loop Until p <> 0
For R = br To br1
For c = bc To bc1
If Cells(R, c).Value <> "" Then
Cells(R, c).Value = Cells(R, c).Value * (1 - (p / 100))
End If
Next c
Next R
End Sub
Sub SubTotal()
'
' Macro1 Macro
' Macro recorded 10/26/02 by Setiono
'
'
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
i = 0
Counter = 0
For Counter = X1Cell To 65536
If Left(Cells(Counter, Y1Cell), 1) = "" Then
i = i + 1
If Left(Cells(Counter + 1, Y1Cell), 1) = "" Then
If Left(Cells(Counter + 2, Y1Cell), 1) = "" Then
EofR = Counter
Exit For
End If
End If
End If
Next
Do
Ask = UCase(InputBox("Insert 1 row after Total? (Y/N)", "Additional Row Confirmation", "Y"))
Loop Until Ask = "Y" Or Ask = "N"
If Ask = "Y" Then EofR = EofR + i
For n = X1Cell To EofR
If Cells(n, Y1Cell) <> "" Then
V = V + Cells(n, Y1Cell).Value
Else
Cells(n, Y1Cell).Value = V
Cells(n, Y1Cell).Font.Bold = True
Cells(n, Y1Cell).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
V = 0
If Ask = "Y" Then
Rows(n + 1).Select
Selection.Insert Shift:=xlDown
n = n + 1
End If
End If
Next n
'Cells(Y1Cell, X1Cell).Select
End Sub
Sub EraseBlankRow()
Dim Counter, p, M As Long
Counter = 0
p = 0
M = 0
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
'Delete Single Empty Row
For Counter = X1Cell To 65536
If Left(Cells(Counter, Y1Cell), 3) = "" Then
If Left(Cells(Counter + 1, Y1Cell), 3) = "" Then
If Left(Cells(Counter + 2, Y1Cell), 3) = "" Then
p = Counter
Exit For
End If
End If
M = M + 1
End If
Next
For Counter = X1Cell To (p - M)
If Left(Cells(Counter, Y1Cell), 3) = " " Then
Cells(Counter, Y1Cell).EntireRow.Delete
End If
If Left(Cells(Counter, Y1Cell), 3) = "" Then
Cells(Counter, Y1Cell).EntireRow.Delete
End If
If Left(Cells(Counter + 1, Y1Cell), 3) = " " Then
Cells(Counter + 1, Y1Cell).EntireRow.Delete
End If
If Left(Cells(Counter + 1, Y1Cell), 3) = "" Then
Cells(Counter + 1, Y1Cell).EntireRow.Delete
End If
Next
End Sub
Sub FillBlank()
'
' Macro7 Macro
' Macro recorded 10/26/02 by Setiono
'
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
' Selection.Copy
End Sub
Sub FormatInvoice()
'
' FormatSAPLInvoice Macro
' Macro recorded 11/12/02 by Setiono
'
'
Sheets("Sheet1").Select
Sheets("Sheet1").Copy After:=Sheets(1)
Rows("1:4").Delete Shift:=xlUp
EofR = IsEOF(4, 1)
For n = 1 To EofR
If Cells(n, 4) = "" Then Cells(n, 4).EntireRow.Delete
If Left(Cells(n, 4), 4) = "P/O:" Then Cells(n, 4).EntireRow.Delete
If Left(Cells(n, 4), 3) = "SUB" Then Cells(n, 4).EntireRow.Delete
If Left(Cells(n, 4), 5) = "GRAND" Then
For NN = 1 To 7
Cells(n, 4).EntireRow.Delete
Next NN
End If
Next n
Range("D1").Select
EraseBlankRow
Range("D1").Select
EraseBlankRow
Columns("A:B").Delete Shift:=xlToLeft
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
SplitDifferentItem
Range("C1").Select
SubTotal
Range("F1").Select
SubTotal
Columns("D:E").Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.NumberFormat = _
"_([$USD] * #,##0.00_);_([$USD] * (#,##0.00);_([$USD] * ""-""??_);_(@_)"
Selection.ColumnWidth = 20.14
Columns("B:B").Cut
Columns("A:A").Insert Shift:=xlToRight
Range("A1").Select
Sheets("Sheet1 (2)").Select
Sheets("Sheet1 (2)").Copy After:=Sheets(2)
EofR = IsEOF(3, 1)
B = 1
For n = 1 To EofR
If Cells(n, 2) = "" Then
Range(Cells(n, 3), Cells(n, 4)).Cut
Cells(B, 3).Select
ActiveSheet.Paste
B = n + 1
End If
Next n
Range("B1").Select
EraseBlankRow
For n = 2 To IsEOF(2, 1)
If Cells(n, 2).Value = Cells(n - 1, 2).Value Then
While Cells(n, 2).Value = Cells(n - 1, 2).Value And Cells(n, 2).Value <> ""
Cells(n, 2).EntireRow.Delete
Wend
End If
Next n
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Selection.ColumnWidth = 6.14
Range("A1").Select
ActiveCell.FormulaR1C1 = "1"
Range("B1").Select
Selection.End(xlDown).Select
X1Cell = ActiveCell.Row
Range(Cells(1, 1), Cells(X1Cell, 1)).Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
step:=1, Trend:=False
Range("A1").Select
End Sub
Sub CloneSheet()
'
' CloneSheet Macro
' Macro recorded 11/12/02 by Setiono
'
ActiveSheet.Copy After:=Sheets(Sheets.Count)
End Sub
Sub DelEntireRow()
'
' DelEntireRow Macro
' Macro recorded 11/15/02 by Setiono
'
'
Selection.EntireRow.Delete
End Sub
Sub ClonePOIssuingList()
'
' Macro1 Macro
' Macro recorded 11/14/02 by Setiono
'
V = Range("A24").Value
V = V + 1
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Range("A10:I24").ClearContents
Range("A10").Value = V
Range("A10:A24").Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
step:=1, Trend:=False
ActiveSheet.Name = Range("A10").Value & "-" & Range("A24").Value
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("B10").Select
End Sub
Sub DeleteActiveSheet()
' Macro recorded 11/15/02 by Setiono
'
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End Sub
Sub DateConvert()
'
' Macro1 Macro
' Macro recorded 12/13/02 by Setiono
'
Dim AC As Long, AR As Long, ARE As Long
AC = ActiveCell.Column
AR = ActiveCell.Row
Selection.Cells(Selection.Cells.Count).Select
ARE = ActiveCell.Row
ConvertDate AC, AR, ARE
End Sub
Sub SequenceNo()
'
' Macro3 Macro
' Macro recorded 12/28/02 by Setiono
'
'
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
step:=1, Trend:=False
End Sub
Sub DelRedudantPart()
Dim x As Long, Y As Long
x = ActiveCell.Column
Y = ActiveCell.Row
For n = Y To IsEOF(Y, x)
If Cells(n, x) = Cells(n + 1, x) And Cells(n, x) = Cells(n + 2, x) And Cells(n, x) <> "" Then
Cells(n + 1, x).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Else
If Cells(n, x) = Cells(n + 1, x) And Cells(n, x) <> "" Then
Cells(n + 1, x).ClearContents
End If
End If
Next n
Range("A1").Select
End Sub
Sub Compact_SubTotal()
'
' Macro1 Macro
' Macro recorded 10/26/02 by Setiono
'
Dim Y1Cell As Long, X1Cell As Long, B As Long
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
i = 0
Counter = 0
For Counter = X1Cell To 65536
If Left(Cells(Counter, Y1Cell), 1) = "" Then
i = i + 1
If Left(Cells(Counter + 1, Y1Cell), 1) = "" Then
If Left(Cells(Counter + 2, Y1Cell), 1) = "" Then
EofR = Counter
Exit For
End If
End If
End If
Next
EofR = EofR + i
For n = X1Cell To EofR
If Cells(n, Y1Cell) <> "" Then
V = V + Cells(n, Y1Cell).Value
Else
Cells(n, Y1Cell).Value = V
Cells(n, Y1Cell).Font.Bold = True
Cells(n, Y1Cell).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
V = 0
Rows(n + 1).Select
Selection.Insert Shift:=xlDown
n = n + 1
End If
Next n
'Y1Cell = ActiveCell.Column
'X1Cell = ActiveCell.Row
'EofR = IsEOF(Y1Cell, X1Cell)
B = X1Cell
For n = X1Cell To EofR
If Cells(n, Y1Cell) = "" Then
Cells(n - 1, Y1Cell).Cut
Cells(B, Y1Cell).Select
ActiveSheet.Paste
B = n + 1
End If
Next n
For n = X1Cell + 1 To EofR
Cells(n, Y1Cell).Select
While Cells(n, Y1Cell) <> ""
ActiveCell.EntireRow.Delete
Wend
ActiveCell.EntireRow.Delete
n = n + 1
If Cells(n, Y1Cell) = "" Then Exit For
Next n
Cells(X1Cell, Y1Cell).Select
End Sub
Sub ConvertNo2Date()
'
' ConvertNo2Date Macro
' Macro recorded 2/18/03 by Setiono
'
'
Selection.NumberFormat = "dd-mmm-yy"
End Sub
Sub CombineCells2Left()
'
' CombineCells2Left Macro
' Macro recorded 27/8/03 by Setiono
'
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
Selection.Cells(Selection.Cells.Count).Select
Y1CE = ActiveCell.Column
X1CE = ActiveCell.Row
sw = 0
For n = X1Cell To X1CE
For o = Y1Cell To Y1CE
Cells(n, Y1Cell).Value = Cells(n, Y1Cell).Value & _
Cells(n, o + 1).Value
If sw <> 0 Then Cells(n, o).Value = ""
sw = sw + 1
Next o
Next n
End Sub
Sub CombineCells2LeftWithComma()
'
' CombineCells2Left Macro
' Macro recorded 27/8/03 by Setiono
'
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
Selection.Cells(Selection.Cells.Count).Select
Y1CE = ActiveCell.Column
X1CE = ActiveCell.Row
sw = 0
For n = X1Cell To X1CE
For o = Y1Cell To Y1CE
Cells(n, Y1Cell).Value = Cells(n, Y1Cell).Value & ", " & _
Cells(n, o + 1).Value
If sw <> 0 Then Cells(n, o).Value = ""
sw = sw + 1
Next o
Next n
End Sub
Sub ImportPO()
'
' FormatPO Macro
' Macro recorded 2/19/03 by Setiono
'
Application.DisplayAlerts = False
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF.PO", Origin:=xlWindows, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(16 _
, 1), Array(29, 1), Array(53, 1), Array(62, 1), Array(68, 1), Array(72, 1), Array(85, 1))
Columns("B:B").ColumnWidth = 18.57
Columns("B:B").ColumnWidth = 15.86
Columns("C:C").ColumnWidth = 19.86
Columns("C:C").ColumnWidth = 22.29
ActiveWorkbook.SaveAs FileName:= _
"D:\Documents & Settings\Job\Vendor\1110030 - Sanyo Semiconductor (S) Pte, Ltd\PO LIST\NEW_PO.xls", FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub FormatPO()
'
' Macro7 Macro
' Macro recorded 2/19/03 by Setiono
'
'Delete header other than the first header
'Dim vcode As Long
EofRowC = InputBox("Enter End of Row", "End of Row Usage Confirmation")
For Counter = 1 To EofRowC
If Left(Cells(Counter, 1), 5) = "SANYO" Or Left(Cells(Counter, 1), 2) = "PT" Or _
Left(Cells(Counter, 1), 4) = "PANA" Or Left(Cells(Counter, 1), 3) = "HPC" Or _
Left(Cells(Counter, 1), 4) = "FUJI" Or Left(Cells(Counter, 1), 7) = "SHINDEN" Then
vcode = Right(Cells(Counter + 3, 3), 7)
Cells(Counter + 7, 5).Value = vcode
Counter = Counter - 1
For p = 1 To 8
Cells(Counter, 1).Select
Selection.EntireRow.Delete
Next p
End If
If Left(Cells(Counter, 3), 19) = "* TO BE CONTINUED *" Then
Cells(Counter, 3).Select
Selection.EntireRow.Delete
End If
Next
'Combine Model and Lot from cell A and C and D become A and B
For Counter = 1 To EofRowC
If Cells(Counter, 7).Value = "" And Cells(Counter + 1, 7).Value <> "" Then
Range(Cells(Counter, 2), Cells(Counter, 4)).Select
br = ActiveCell.Row
bc = ActiveCell.Column
Selection.Cells(Selection.Cells.Count).Select
br1 = ActiveCell.Row
bc1 = ActiveCell.Column
For R = br To br1
For c = bc + 1 To bc1
Cells(R, bc).Value = Cells(R, bc).Value & Cells(R, c).Value
Cells(R, c).ClearContents
Next c
Next R
Cells(br, bc).Select
Cells(Counter, 3).Value = Cells(Counter, 5).Value
Cells(Counter, 5).ClearContents
End If
Next Counter
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
For n = 1 To IsEOF(1, 4)
If Cells(n, 4) <> "" And Cells(n, 9) = "" Then
Range(Cells(n, 4), Cells(n, 6)).Select
Selection.Cut Destination:=Range(Cells(n + 1, 1), Cells(n + 1, 3))
End If
Next n
Range("D1").Select
EraseBlankRow
EofCellUsage = IsEOF(1, 4)
If EofCellUsage > 1 Then
Range(Cells(1, 1), Cells(EofCellUsage, 3)).Select
FillBlank
End If
Columns("A:C").Select
ConvertCellsContent2Value
Columns("A:A").NumberFormat = "0000000000"
Rows("1:1").Insert Shift:=xlDown
Range("A1").FormulaR1C1 = "P.O. NO."
Range("B1").FormulaR1C1 = "MODEL/LOT"
Columns("B:B").ColumnWidth = 15.29
Range("C1").FormulaR1C1 = "V. CODE"
Range("D1").FormulaR1C1 = "DLV. DATE"
Columns("D:D").ColumnWidth = 10
Range("E1").FormulaR1C1 = "PART CODE"
Range("F1").FormulaR1C1 = "PART DESCRIPTION"
Range("H1").FormulaR1C1 = "P.O. QTY."
Range("J1").FormulaR1C1 = "PRICE"
Columns("J:J").ColumnWidth = 12.71
Range("K1").FormulaR1C1 = "AMOUNT"
Columns("J:J").Select
Selection.NumberFormat = _
"_($* #,##0.0000_);_($* (#,##0.0000);_($* ""-""????_);_(@_)"
Columns("K:K").Select
Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Columns("G:G").Delete Shift:=xlToLeft
Columns("H:H").Delete Shift:=xlToLeft
Range(Cells(2, 4), Cells(IsEOF(2, 4), 4)).Select
For n = 2 To IsEOF(2, 4)
If Cells(n, 4) <> "" Then
CellTMP = Cells(n, 4).Value
CellTMP = "'" & CellTMP
Cells(n, 4).Select
'Selection.FormulaR1C1 = CellTMP
If Mid(CellTMP, 3, 1) = "/" Then
Selection.Value = _
Mid(CellTMP, 2, 1) & "/" & Right(CellTMP, 2) & "/" & "200" & Mid(CellTMP, 4, 1)
Else
Selection.Value = _
Mid(CellTMP, 2, 2) & "/" & Right(CellTMP, 2) & "/" & "200" & Mid(CellTMP, 5, 1)
End If
'Selection.Value = Mid(CellTMP, 2, 1) & "/" & Right(CellTMP, 2) & "/" & "200" & Mid(CellTMP, 4, 1)
Selection.NumberFormat = "d-mmm-yy"
End If
Next n
Range("A1").Select
End Sub
Sub ImportRollingForcast()
'
' ImportRollingForcast Macro
' Macro recorded 2/21/03 by Setiono
'
Application.DisplayAlerts = False
nm = InputBox("Nama forecast file - tsfsplf.???????", , "forecast")
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF." & nm, Origin:= _
xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, _
1), Array(16, 1), Array(42, 1), Array(47, 1), Array(57, 1), Array(67, 1), Array(77, 1), _
Array(87, 1), Array(97, 1), Array(107, 1))
Columns("A:A").Insert Shift:=xlToRight
For n = 5 To 10
CellTMP = "'" & Cells(6, n)
If Mid(CellTMP, 5, 1) = "/" Then
Cells(6, n).Value = Mid(CellTMP, 4, 1) & "/200" & Right(CellTMP, 1)
Else
Cells(6, n).Value = Mid(CellTMP, 4, 2) & "/200" & Right(CellTMP, 1)
End If
Cells(6, n).NumberFormat = "mmm-yy"
Next n
t = Mid(Cells(5, 3), 13, 7)
Cells(8, 1).Value = t
Cells(5, 1).EntireRow.Delete
Range("b1:c4").ClearContents
Range("d4", "d5").ClearContents
Range("e4").ClearContents
Range("j1:k2").ClearContents
Range("j1").Value = "DAT" & Range("h1").Value & Left(Range("i1").Value, 1)
Range("j2").Value = "DAT" & Range("h2").Value & Left(Range("i2").Value, 1)
Range("g1:i2").ClearContents
Range("d2:f2").Select
CombineCells2Left
Range("A5").Select
ActiveCell.FormulaR1C1 = "V. CODE"
Range("A6").Select
ActiveCell.FormulaR1C1 = "'-----------"
Range("A7").Select
For Counter = 6 To 65536
If Left(Cells(Counter, 2), 8) = "BXA052PA" Then
Counter = Counter - 1
For p = 1 To 4
Cells(Counter + 1, 1).Select
Cells(Counter + 1, 1).EntireRow.Delete
Next p
t = Mid(Cells(Counter + 1, 3), 13, 7)
Cells(Counter + 4, 1).Value = t
Cells(Counter + 1, 1).EntireRow.Delete
Cells(Counter + 1, 1).EntireRow.Delete
Cells(Counter + 1, 1).EntireRow.Delete
End If
Next
Columns("B:B").ColumnWidth = 16#
Columns("C:C").ColumnWidth = 29.57
EndRowUsage = IsEOF(7, 4)
Range(Cells(7, 1), Cells(EndRowUsage, 1)).Select
FillBlank
ActiveWorkbook.SaveAs FileName:= _
"D:\Documents & Settings\Job\Rolling Forecast\Rolling Frocast.xls", FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub SortMDLDummy()
'
' SortMDLDummy Macro
' Macro recorded 3/5/03 by Setiono
'
'
Selection.Sort Key1:=Range("E471"), Order1:=xlAscending, Key2:=Range( _
"F471"), Order2:=xlAscending, Key3:=Range("D471"), Order3:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom
End Sub
Sub MovingPONO2topleftside()
'
' Macro4 Macro
' Macro recorded 3/14/03 by Setiono
'
For n = 5 To 25
If Cells(n, 9).Value <> "" Then
Cells(n - 1, 3).Value = Cells(n, 9).Value
Cells(n - 1, 4).Value = Cells(n, 10).Value
End If
Next n
End Sub
Sub GTotal()
'
' Macro1 Macro
' Macro recorded 10/26/02 by Setiono
'
Dim Y1Cell As Long
Dim X1Cell As Long
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
EofR = IsEOF(X1Cell, Y1Cell)
For n = X1Cell To EofR
If Cells(n, Y1Cell) = "" Then
V = V + Cells(n - 1, Y1Cell).Value
End If
Next n
Cells(n - 1, Y1Cell).Value = V
Cells(n - 1, Y1Cell).Font.Bold = True
Cells(n - 1, Y1Cell).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
Cells(Y1Cell, X1Cell).Select
End Sub
Sub MergeCenter()
'
' MergeCenter Macro
' Macro recorded 3/27/03 by Setiono
'
'
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = True
End With
End Sub
Sub InsertRow()
'
' InsertRow Macro
' Macro recorded 3/14/03 by Setiono
'
'
Selection.EntireRow.Insert
End Sub
Sub ConvertMinus()
Dim Y1Cell As Long, X1Cell As Long
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
For n = X1Cell To IsEOF(Y1Cell, X1Cell)
If Right(Cells(n, Y1Cell), 1) = "-" Then Cells(n, Y1Cell).Value = _
-1 * (Left(Cells(n, Y1Cell), Len(Cells(n, Y1Cell)) - 1))
Next n
Cells(X1Cell, Y1Cell).Select
End Sub
Sub Validate()
Dim Y1Cell As Long, X1Cell As Long, p As Long
Y1Cell = ActiveCell.Column
X1Cell = ActiveCell.Row
p = 0#
a = InputBox("Baris Akhir ?")
For n = X1Cell To a 'IsEOF(Y1Cell, X1Cell)
p = Cells(n, Y1Cell).Value
Cells(n, Y1Cell).Value = p
'Cells(n, Y1Cell).Select
Next n
Cells(X1Cell, Y1Cell).Select
' ActiveCell.FormulaR1C1 = "630"
' Range("H16").Select
End Sub
Sub UpdateTVSpec()
'
' UpdateTVSpec Macro
' Macro recorded 5/21/03 by Setiono
'
'
Application.DisplayAlerts = False
Workbooks.Open FileName:= _
"D:\Documents & Settings\Job\Support\SOPIS\TvSpec\TvSpec.csv"
Columns("G:G").ColumnWidth = 10
Columns("F:F").ColumnWidth = 13.14
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "MODEL"
Range("B1").Select
ActiveCell.FormulaR1C1 = "CHASSIS"
Range("C1").Select
ActiveCell.FormulaR1C1 = "SIZE"
Range("D1").Select
ActiveCell.FormulaR1C1 = "DEST."
Range("E1").Select
ActiveCell.FormulaR1C1 = "SYSTEM"
Range("F1").Select
ActiveCell.FormulaR1C1 = "D. ENG INC"
Range("G1").Select
ActiveCell.FormulaR1C1 = "PRD. NO."
Range("G2").Select
Columns("F:F").ColumnWidth = 14.86
ActiveWorkbook.SaveAs FileName:= _
"D:\Documents & Settings\Job\Support\SOPIS\TvSpec\TvSpec.xls", FileFormat:= _
xlExcel9795, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub FormatMDL()
'
' FormatMDL Macro
' Macro recorded 5/23/03 by Setiono
'
'
Application.DisplayAlerts = False
Do
AskName = UCase(InputBox("Input Model Name? (ex: C5SR#305, Must exist TSFSPLF.C5SR#305 in C:\WINDOWS", "File Name Confirmation"))
Loop Until AskName <> ""
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF." & AskName, Origin:= _
xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, _
1), Array(7, 1), Array(13, 1), Array(15, 1), Array(30, 1), Array(34, 1), Array(61, 1), Array _
(64, 1), Array(67, 1), Array(71, 1), Array(73, 1), Array(82, 1), Array(83, 1), Array(85, 1), _
Array(89, 1), Array(105, 1), Array(106, 1), Array(109, 1), Array(117, 1), Array(130, 1))
ActiveWindow.Zoom = 75
Columns("D:D").ColumnWidth = 15.44
Columns("F:F").ColumnWidth = 25.57
Columns("L:L").ColumnWidth = 2.29
Columns("O:O").ColumnWidth = 11.29
Columns("P:P").ColumnWidth = 2.29
Range("A1:K3").Select
Selection.ClearContents
Range("A5").Select
Selection.ClearContents
Range("A4:F4").Select
Selection.Cut Destination:=Range("D4")
Range("D4:I4").Select
br = ActiveCell.Row
bc = ActiveCell.Column
Selection.Cells(Selection.Cells.Count).Select
br1 = ActiveCell.Row
bc1 = ActiveCell.Column
For R = br To br1
For c = bc + 1 To bc1
Cells(R, bc).Value = Cells(R, bc).Value & " " & Cells(R, c).Value
Cells(R, c).ClearContents
Next c
Next R
Columns("A:C").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("C:F").Select
Selection.Delete Shift:=xlToLeft
Columns("D:F").Select
Selection.Delete Shift:=xlToLeft
Columns("E:F").Select
Selection.Delete Shift:=xlToLeft
Range("D1:G5").Select
Selection.ClearContents
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").ColumnWidth = 14.71
Range("A1").Select
ActiveWorkbook.SaveAs FileName:="D:\Documents & Settings\Job\Models\" & AskName & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub CostDownReportMaker()
'Sub CDRTitle()
'
' CDRTitle Macro
' Macro recorded 8/18/2003 by Setiono
'
'
Range("A1").Select
Selection.EntireRow.Insert
Range("L1:M1").Select
Selection.EntireColumn.Delete
Range("K1").Select
ActiveCell.FormulaR1C1 = "Current"
Range("K2").Select
ActiveCell.FormulaR1C1 = "Price"
Range("L2").Select
Selection.EntireColumn.Insert
ActiveCell.FormulaR1C1 = "Amount"
Range("M1").Select
ActiveCell.FormulaR1C1 = "Standard"
Range("M2").Select
ActiveCell.FormulaR1C1 = "Price"
Range("M3").Select
ActiveWindow.Zoom = 75
Range("K1").Select
Selection.EntireColumn.Insert
Range("K2").Select
ActiveCell.FormulaR1C1 = "Total"
Range("O2").Select
ActiveCell.FormulaR1C1 = "Amount"
Rows("1:1").Select
Range("C1").Activate
Selection.Font.Bold = True
Rows("2:2").Select
Range("C2").Activate
With Selection.Font
.Name = "MS Sans Serif"
.Size = 10
End With
Columns("N:O").Cut
Columns("L:L").Insert Shift:=xlToRight
Range("P1").FormulaR1C1 = "Difference"
Range("P2").FormulaR1C1 = "Amount"
Range("Q2").FormulaR1C1 = "%"
Range("R1").FormulaR1C1 = "New"
Range("R2").FormulaR1C1 = "Price"
Range("S2").FormulaR1C1 = "Amount"
Range("T1").FormulaR1C1 = "Difference"
Range("T2").FormulaR1C1 = "Amount"
Range("U2").FormulaR1C1 = "%"
Range("L1:M1").Merge
Range("N1:O1").Merge
Range("P1:Q1").Merge
Range("R1:S1").Merge
Range("T1:U1").Merge
Range("A1:U2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
End With
Range("A1:A2").Merge
Range("B1:B2").Merge
Range("C1:C2").Merge
Range("D1:D2").Merge
Range("E1:E2").Merge
Range("F1:F2").Merge
Range("G1:G2").Merge
Range("H1:H2").Merge
Range("I1:I2").Merge
Range("J1:J2").Merge
Range("K1:K2").Merge
Range("A1:A2").Select
Range("K3").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-6]:RC[-1])"
Range("J4").Select
Selection.End(xlDown).Select
Range("K96").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Range("E3:K96").Select
Range("K96").Activate
Selection.NumberFormat = "#,##0"
Range("K95").Select
Selection.End(xlUp).Select
Range("M3").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]"
Range("L3").Select
Selection.End(xlDown).Select
Range("M96").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Range("L96").Select
Range(Selection, Selection.End(xlUp)).Select
Range("L95").Select
Selection.End(xlUp).Select
Range("L3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="#N/A", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("O3").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-4]"
Range("N3").Select
Range(Selection, Selection.End(xlDown)).Select
Range("N3").Select
Selection.End(xlDown).Select
Range("O96").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Range("O95").Select
Range("M58").Select
Selection.End(xlUp).Select
Range("M3:O3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "#,##0.00"
Range("P3").Select
ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-3]"
Range("O4").Select
Selection.End(xlDown).Select
Range("P96").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Selection.End(xlUp).Select
Range("P3").Select
ActiveCell.FormulaR1C1 = "=RC[-3]-RC[-1]"
Range("O3").Select
Selection.End(xlDown).Select
Range("P96").Select
Range(Selection, Selection.End(xlUp)).Select
Range("P3:P96").Select
Range("P96").Activate
Selection.FillDown
Range("Q96").Select
Selection.End(xlUp).Select
Range("Q3").Select
ActiveCell.FormulaR1C1 = "=RC[-1]/RC[-4]"
Range("P3").Select
Selection.End(xlDown).Select
Range("Q96").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Selection.Style = "Percent"
Selection.NumberFormat = "0.0%"
Selection.NumberFormat = "0.00%"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Replace What:="#DIV/0!", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.End(xlUp).Select
Application.CutCopyMode = False
Columns("P:P").ColumnWidth = 9.57
'End Sub
'Sub CDR1()
'
' CDR2 Macro
' Macro recorded 8/18/2003 by Setiono
'
'
Dim FirstRow As Long, DiffCol As Long, c As Long, n As Long, p As Long
FirstRow = 3
DiffCol = 1
'Remove space on Active Cell Column
Range(Cells(Val(FirstRow), DiffCol), Cells(IsEOF(1, 1), DiffCol)).Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
p = IsEOF(FirstRow, DiffCol)
p = p - 1
FirstRow = FirstRow + 1
c = 0
BeginRow = FirstRow
EndRow = p
n = 0
Range(Cells(1, 1), Cells(1, 13)).Select
With Selection.Font
.Name = "Arial"
.Size = 10
End With
For n = FirstRow To p
If Cells(n, DiffCol) <> Cells(n - 1, DiffCol) Then
c = c + 1
End If
Next n
For n = BeginRow To EndRow + (c * 2)
If Cells(n, DiffCol) <> Cells(n - 1, DiffCol) And Cells(n, DiffCol) <> "" Then
Cells(n, DiffCol).EntireRow.Insert
Cells(n, DiffCol).EntireRow.Insert
'Range(Cells(n, DiffCol), Cells(n+1, 21)).Value = Range(Cells(1, 1), Cells(1, 13)).Value
'format cells into bold style and desire date format
'Range(Cells(n, DiffCol), Cells(n, 13)).Font.Bold = True
'Range(Cells(n, 5), Cells(n, 10)).NumberFormat = "[$-409]mmm-yy;@"
Range(Cells(1, 1), Cells(2, 21)).Copy
Cells(n, DiffCol).PasteSpecial xlPasteAll
'Range(Cells(n, 1), Cells(n, 14)).Borders(xlInsideVertical).LineStyle = xlNone
'Range(Cells(n, 1), Cells(n, 14)).Interior.ColorIndex = xlNone
n = n + 2
End If
Next n
ActiveWindow.Zoom = 75
Columns("A:A").ColumnWidth = 13.43
Columns("B:B").ColumnWidth = 26.43
'End Sub
'Sub CDR2()
'
' CDR Macro
' Macro recorded 8/18/2003 by Setiono
'
'
Application.CutCopyMode = False
Do
AskPeriode = InputBox("Periode ?", "Input Periode Confirmation")
Loop Until AskPeriode <> ""
For n = 1 To 65536
If Cells(n, 1).Value = "VENDOR NO." Then
c = c + 1
'n = n + 1
End If
If Cells(n, 1).Value = "" And Cells(n + 1, 1).Value = "" Then
E = n
Exit For
End If
Next n
For n = 1 To E + (c * 5)
If Cells(n, 1).Value = "VENDOR NO." Then
Cells(n, 1).Select
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Range(Cells(n + 2, 3), Cells(n + 3, 21)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Merge True
End With
Cells(n + 2, 3).FormulaR1C1 = "COSTDOWN REPORT OF " & Cells(n + 8, 2).Value
Cells(n + 3, 3).FormulaR1C1 = "PERIODE " & AskPeriode
Cells(n + 2, 3).Select
With Selection.Font
.Name = "Arial"
.Size = 12
End With
Selection.Font.Bold = True
Cells(n + 3, 3).Font.Bold = True
n = n + 8
End If
Next n
Range("A1:B1").Select
Selection.EntireColumn.Delete
Range("A9").Select
ActiveWindow.DisplayGridlines = False
'End Sub
End Sub
Sub ScheduleMaker_Step_1()
'
' Format1PrdSchd Macro
' Macro recorded 9/16/03 by Setiono
'
'
Application.DisplayAlerts = False
ActiveWindow.Zoom = 75
On Error Resume Next
Do
nm1 = LCase(InputBox("Sanyo Semicon? (Y/T)", "T"))
Loop Until nm1 = "y" Or nm1 = "t"
If nm1 = "t" Then
ActiveWorkbook.SaveAs FileName:= _
"D:\Schedule.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Else
ActiveWorkbook.SaveAs FileName:= _
"D:\Documents & Settings\Job\Vendor\1110030 - Sanyo Semiconductor (S) Pte, Ltd\Micro Controller\Micon's Production Schedule\Schedule.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End If
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
ActiveWindow.FreezePanes = False
Application.CutCopyMode = False
Do
ada = LCase(InputBox("Ada Autofilter? (Y/T)", "Autofilter Remover", "T"))
Loop Until ada = "y" Or ada = "t"
If ada = "y" Then Selection.AutoFilter
Range("B1:E4").ClearContents
Range("F4").ClearContents
Range("U3:AH3").ClearContents
Range("T3").ClearContents
Range("AD2").ClearContents
Columns("C:C").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-NZ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-AA", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-M", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-SA", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-EU", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="-WG", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="#", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="$", Replacement:="T", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Columns("H:H").Insert Shift:=xlToRight
Selection.ColumnWidth = 13.14
Range("G7").Select
Columns("H:H").ColumnWidth = 18.43
For n = 7 To 700
If Cells(n, 3).Value = "E" And Left(Cells(n, 4), 4) = "LINE" Then
Cells(n, 3).EntireRow.Delete
Cells(n, 3).EntireRow.Delete
Exit For
Else
While Cells(n, 7).Value = "" And Not (Cells(n, 3).Value = "E" And _
Left(Cells(n, 4), 4) = "LINE") Or Cells(n, 7).Value = "CHASS"
Cells(n, 7).Select
Selection.EntireRow.Delete
Wend
End If
If Cells(n, 3).Value = "E" And Left(Cells(n, 4), 4) = "LINE" Then
Cells(n, 3).EntireRow.Delete
Cells(n, 3).EntireRow.Delete
Exit For
End If
Next n
'******* remove all shape except for 1st Sanyo Logo *********
Do
On Error Resume Next
c = ActiveSheet.Comments.Count
For n = 1 To c
ActiveSheet.Comments(n).Shape.Select
Selection.Delete
Next n
Loop Until c = 0
Do
On Error Resume Next
c = ActiveSheet.Shapes.Count
For n = 2 To c
ActiveSheet.Shapes(n).Delete
Next n
Loop Until c = 1
'***********************************************************
Columns("B:G").Font.Bold = False
Range("F3").Font.Bold = True
'***************Sortir*************************************
Range("AJ5:AJ6").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Font.Bold = True
Selection.Font.ColorIndex = 0
ActiveCell.FormulaR1C1 = "Casing"
wherex = 8 'ActiveCell.Column
wherey = 7 'ActiveCell.Row
Akhirkol = 33
Akhirbrs = IsEOF(7, 2)
For baris = wherey To Akhirbrs
For kolom = wherex To Akhirkol
Cells(baris, kolom + 1).Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False
Cells(baris, kolom + 1).NumberFormat = "0"
Cells(baris, kolom + 1).Value = Cells(baris, kolom + 1).Value
If Cells(baris, kolom + 1) <> "" Then
Cells(baris, wherex).Value = _
Cells(wherey - 1, kolom + 1).Value
Exit For
Else
End If
Next kolom
Cells(baris, 35).FormulaR1C1 = "=SUM(RC[-25]:RC[-1])"
Cells(baris, 36).Value = Cells(baris, 8).Value
Cells(baris, 8).Value = ""
Cells(baris, 36).Select
Selection.NumberFormat = "d-mmm-yy"
Selection.Font.Bold = False
Selection.Font.ColorIndex = 0
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
Next baris
sw = 0
For baris = wherey To Akhirbrs
For kolom = wherex To Akhirkol
If Cells(baris, kolom + 1).Value = "0" Then
Cells(baris, kolom + 1).EntireRow.Delete
sw = 1
If sw = 1 Then
baris = baris - 1
sw = 0
End If
Exit For
End If
Next kolom
Next baris
Akhirbrs = IsEOF(7, 2)
Range(Cells(7, 8), Cells(Akhirbrs, 35)).Select
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
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlDot
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Selection.NumberFormat = 0
Cells.Replace What:="<", Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False
Cells.Replace What:=">", Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False
Range(Cells(7, 2), Cells(Akhirbrs, 36)).Sort _
Key1:=Range("C7"), Order1:=xlAscending, Key2:=Range("D7") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
ActiveWorkbook.Save
'************************* Step 2 *******************************
' Check for Double Model
For n = 7 To IsEOF(7, 3)
If Cells(n, 3).Value = Cells(n - 1, 3).Value And _
Cells(n, 4).Value = Cells(n - 1, 4).Value And _
Cells(n, 5).Value = Cells(n - 1, 5).Value Then
If Cells(n, 36) > Cells(n - 1, 36) Then
Cells(n, 36).Select
Selection.EntireRow.Delete
Else
Cells(n - 1, 36).Select
Selection.EntireRow.Delete
End If
End If
If Cells(n, 3).Value = Cells(n + 1, 3).Value And _
Cells(n, 4).Value = Cells(n + 1, 4).Value And _
Cells(n, 5).Value = Cells(n + 1, 5).Value Then
If Cells(n, 36) > Cells(n + 1, 36) Then
Cells(n, 36).Select
Selection.EntireRow.Delete
Else
Cells(n + 1, 36).Select
Selection.EntireRow.Delete
End If
End If
If Cells(n, 3).Value = Cells(n - 1, 3).Value And _
Cells(n, 4).Value = Cells(n - 1, 4).Value And _
Cells(n, 5).Value <> Cells(n - 1, 5).Value Then
Range(Cells(n, 2), Cells(n - 1, 7)).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
If Cells(n, 3).Value = Cells(n + 1, 3).Value And _
Cells(n, 4).Value = Cells(n + 1, 4).Value And _
Cells(n, 5).Value <> Cells(n + 1, 5).Value Then
Range(Cells(n, 2), Cells(n + 1, 7)).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
Next n
'************************* Step 3 ******************************
'Sort and remove model(s) with 0 Qty
Akhirbrs = IsEOF(7, 2)
Range(Cells(7, 2), Cells(Akhirbrs, 36)).Sort Key1:=Range("E7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For n = 7 To Akhirbrs - 1
While Cells(n, 5).Value < 5 And Cells(n, 5).Value <> ""
Cells(n, 5).EntireRow.Delete
Wend
Next n
Range(Cells(7, 5), Cells(Akhirbrs, 5)).HorizontalAlignment = xlRight
Range("E7").Select
End Sub
Sub ScheduleMaker_Step_2()
'************************** Step 4 *****************************
'make border
Range(Cells(7, 2), Cells(IsEOF(7, 2), 36)).Select
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 = xlDot
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlDot
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'************************************ Step 5 ***********************************************************
'Link to Micon's Models(s)
Do
nm = LCase(InputBox("Sanyo Semicon bukan? Ya/Bukan (Y/B)", "B"))
Loop Until nm = "y" Or nm = "b"
If nm = "b" Then
lm = InputBox("Nama File yang mau dilink untuk model2 nya?")
'fm = InputBox("Nama Folder tempat filenya?")
'Workbooks.Open FileName:=fm & lm
Else
Workbooks.Open FileName:= _
"D:\Documents & Settings\Job\Vendor\1110030 - Sanyo Semiconductor (S) Pte, Ltd\Micro Controller\Micon Models.xls"
End If
Windows("Schedule.xls").Activate
Range("H7").Select
If nm = "b" Then
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-5],'[lm]Sheet1 (2)'!R2C1:R1317C2,2,FALSE)"
Else
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-5],'[Micon Models.xls]Sheet1 (2)'!R2C1:R452C2,2,FALSE)"
End If
Range("G7").Select
Selection.End(xlDown).Select
Y = ActiveCell.Row
Range(Cells(7, 8), Cells(Y, 8)).Select
Selection.FillDown
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range(Cells(7, 2), Cells(IsEOF(7, 2), 36)).Sort _
Key1:=Range("H7"), Order1:=xlAscending, Key2:=Range("AJ7") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
On Error Resume Next
For n = 7 To IsEOF(7, 8)
sw = 0
If Cells(n, 8) = "#N/A" Then
sw = 1
Cells(n, 8).EntireRow.Delete
End If
If sw = 1 Then
n = n - 1
sw = 0
End If
Next n
Application.CutCopyMode = False
ActiveWorkbook.Save
If nm = "b" Then Windows(lm).Close Else Windows("Micon Models.xls").Close
Windows("Schedule.xls").Activate
wherex = 10
wherey = 7
Akhirkol = 34
Akhirbrs = IsEOF(7, 2)
For baris = wherey To Akhirbrs
For kolom = wherex To Akhirkol
If Cells(baris, kolom) <> "" Then
If kolom - 10 < wherex Then
If kolom - 5 < wherex Then
Cells(baris, kolom).Select
With Selection.Interior
.ColorIndex = 7
.Pattern = xlSolid
End With
Else
Cells(baris, kolom - 5).Value = Cells(baris, kolom).Value
Cells(baris, kolom).Value = ""
Cells(baris, kolom).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
Else
Cells(baris, kolom - 9).Value = Cells(baris, kolom).Value
Cells(baris, kolom).Value = ""
Cells(baris, kolom).Select
With Selection.Interior
.ColorIndex = 35
.Pattern = xlSolid
End With
End If
End If
Next kolom
Next baris
E = IsEOF(7, 2)
Range(Cells(7, 2), Cells(E, 36)).Sort _
Key1:=Range("AJ7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range(Cells(7, 8), Cells(E, 36)).Select
With Selection
.Font.Bold = False
.Font.Italic = False
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Name = "Times New Roman"
.Font.Size = 10
End With
Range(Cells(7, 8), Cells(E, 35)).Select
Selection.NumberFormat = "0"
End Sub
Sub Format0526()
Application.DisplayAlerts = False
Do
AskName = UCase(InputBox("Input Model Name? (ex: C5SR#305, Must exist TSFSPLF.C5SR#305 in C:\WINDOWS", "File Name Confirmation"))
Loop Until AskName <> ""
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF." & AskName, Origin:=xlWindows, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(22 _
, 1), Array(52, 1), Array(74, 1), Array(87, 1))
Columns("B:B").ColumnWidth = 20.43
Columns("B:B").ColumnWidth = 17.57
Columns("A:A").ColumnWidth = 16.86
Columns("A:A").ColumnWidth = 13.71
Columns("C:C").ColumnWidth = 16.14
Columns("D:D").ColumnWidth = 16.29
Columns("D:D").ColumnWidth = 11
ActiveWindow.Zoom = 75
Range("A1").Select
ActiveWorkbook.SaveAs FileName:="D:\Documents & Settings\Job\Models\" & AskName & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub FormatModel()
Application.DisplayAlerts = False
Do
AskName = UCase(InputBox("Input Model Name? (ex: C5SR#305, Must exist TSFSPLF.C5SR#305 in C:\WINDOWS", "File Name Confirmation"))
Loop Until AskName <> ""
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF." & AskName, Origin:= _
xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, _
1), Array(7, 1), Array(13, 1), Array(15, 1), Array(30, 1), Array(34, 1), Array(61, 1), Array _
(64, 1), Array(67, 1), Array(71, 1), Array(73, 1), Array(82, 1), Array(83, 1), Array(85, 1), _
Array(89, 1), Array(105, 1), Array(106, 1), Array(109, 1), Array(117, 1), Array(130, 1))
ActiveWindow.Zoom = 75
Range("A1").Select
ActiveWorkbook.SaveAs FileName:="D:\Documents & Settings\Job\Models\" & AskName & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Sub ImportMonthlyRcv()
'
' ImportMonthlyRcv Macro
' Macro recorded 10/17/03 by Setiono
'
'
Workbooks.OpenText FileName:="C:\WINDOWS\TSFSPLF.MRCV", Origin:=xlWindows, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(10 _
, 1), Array(26, 1), Array(37, 1), Array(46, 1), Array(47, 1), Array(63, 1), Array(81, 1), _
Array(89, 1), Array(106, 1))
End Sub
Sub SortMDLonPRDSCHD()
'posisi cell aktiv menunjukkan posisi awal cell yg akan diisi
wherex = ActiveCell.Column
wherey = ActiveCell.Row
Do
Akhirkol = LCase(InputBox("Masukkan kolom terakhir dari schedule (A=1, B=2, ...)", "Tanya akhir kolom"))
Loop Until Akhirkol <> "" And Akhirkol > 0
Do
Akhirbrs = LCase(InputBox("Masukkan Baris terakhir dari schedule (1, 2, ...)", "Tanya akhir baris"))
Loop Until Akhirbrs <> "" And Akhirbrs > 0
'Do
' BrsTgl = LCase(InputBox("Masukkan baris tanggal dari schedule...", "Tanya baris tanggal"))
'Loop Until BrsTgl <> "" And BrsTgl > 0
For baris = wherey To Akhirbrs
For kolom = wherex To Akhirkol
If Cells(baris, kolom + 1) <> "" Then
Cells(baris, wherex).Value = _
Cells(wherey - 1, kolom + 1).Value
Exit For
Else
End If
Next kolom
Next baris
End Sub
Sub ConvertCellsContent2Value()
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
'********************************************************************************************
'* SUBROUTINE & FUNCTION
'********************************************************************************************
'Sub Header(SortMethod As String)
'****************** Formatting SAPL Delivery Scedule Header ********************
'End Sub
Function IsEOF(Y As Long, x As Long) As Long
'Function to determine Row after End of usage Row
'Can detect All Cell for 3 Row Blank then this function will treat current cell is Eof Row Usage
'Where X = Column and Y = Row
Counter = 0
For Counter = Y To 65536
If IsEmpty(Cells(Counter, x)) Then
If IsEmpty(Cells(Counter + 1, x)) Then
If IsEmpty(Cells(Counter + 2, x)) Then
IsEOF = Counter - 1
Exit For
End If
End If
End If
Next
End Function
Sub ImportDoc(FileName)
Workbooks.OpenText FileName:=FileName, Origin:=xlWindows, StartRow _
:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(15, 1), Array _
(25, 1), Array(41, 1), Array(50, 2), Array(58, 1), Array(70, 1), Array(82, 1), Array(94, 1), _
Array(106, 2), Array(116, 2), Array(125, 1), Array(139, 1), Array(151, 1), Array(159, 1))
End Sub
Sub ConvertDate(ColumnCell As Long, StartCell As Long, EndCell As Long)
'Subrutin to change SOPIS Date format to Excel Format
'ColumnCel is a Column to be process where the date exist
'StartCell is a Row where this subrutin start to convert the date
'EndCell is a Row where this subrutin stop to convert the date
'Created by Setiono October 19, 2002
For n = StartCell To EndCell
If Not IsEmpty(Cells(n, ColumnCell)) Then
CellTMP = "'" & Cells(n, ColumnCell).Value
Cells(n, ColumnCell).Select
If Mid(CellTMP, 4, 1) = "/" Then
Selection.Value = _
Mid(CellTMP, 4, 1) & "/" & Right(CellTMP, 2) & "/" & "200" & Mid(CellTMP, 2, 1)
Else
Selection.Value = _
Mid(CellTMP, 4, 2) & "/" & Right(CellTMP, 2) & "/" & "200" & Mid(CellTMP, 2, 1)
End If
Selection.NumberFormat = "d-mmm-yy"
Cells(n, ColumnCell).Value = Cells(n, ColumnCell).Value 'validate
End If
Next n
End Sub
Sub FillImplosionsMDL()
'
Dim x As Long, Y As Long, E As Long
x = ActiveCell.Column - 5
Y = ActiveCell.Row
E = IsEOF(Y, x)
For n = Y To E
Cells(n, x + 5).FormulaR1C1 = _
"=IF(RC[-1]<>"""",RC[-1],IF(RC[-2]<>"""",RC[-2],RC[-3]))"
Next n
Range(Cells(Y, x + 5), Cells(E, x + 5)).Select
ConvertCellsContent2Value
End Sub
Sub FillDown()
'
' Macro3 Macro
' Macro recorded 1/30/04 by Setiono
'
'
Dim x As Long, Y As Long, E As Long
x = ActiveCell.Column
Y = ActiveCell.Row
E = IsEOF(Y, x)
'MsgBox (E)
Range(Cells(Y, x), Cells(E, x)).Select
Selection.FillDown
ConvertCellsContent2Value
End Sub
Sub LinkPartImplosionsAndTVSpec()
'
' Macro2 Macro
' Macro recorded 1/30/04 by Setiono
'
Application.Run "Personal.xls!UpdateTVSpec"
ActiveWindow.ActivateNext
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],TvSpec.xls!R2C1:R1272C2,2,FALSE)"
Range("E2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],TvSpec.xls!R2C1:R1272C3,3,FALSE)"
Range("F2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],TvSpec.xls!R2C1:R1272C4,4,FALSE)"
Range("C2:C285").Select
Selection.Replace What:="#", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("D2").Select
Application.Run "Personal.xls!FillDown"
Range("E2").Select
Application.Run "Personal.xls!FillDown"
Range("F2").Select
Application.Run "Personal.xls!FillDown"
Windows("TvSpec.xls").Activate
ActiveWindow.Close
Range("C2").Select
End Sub
Sub Move2Right()
'
' Macro5 Macro
' Macro recorded 1/30/04 by Setiono
'
'
x = ActiveCell.Column
Y = ActiveCell.Row
Selection.End(xlDown).Select
Y1 = ActiveCell.Row
X1 = x
For n = Y + 1 To Y1
X1 = X1 + 1
Cells(Y, X1).Value = Cells(n, x)
Next n
End Sub
Sub HPC_PO_Count()
' HPC_PO_Count Macro
t = 0
B = Val(InputBox("Baris awal yang akan diproses, baris ke..."))
E = Val(InputBox("Baris Terakhir yang akan diproses, baris ke..."))
C1 = Val(InputBox("BAL QTY ada di kolom ke..."))
C2 = Val(InputBox("EOF QTY ada di kolom ke..."))
For n = B To E
Cells(n, 8).Select
t = t + Cells(n, C1).Value
If t >= (Cells(n, C2).Value * -1) Then
If Cells(n + 1, 1).Value = Cells(n, 1).Value Then
While Cells(n + 1, 1).Value <> ""
Cells(n + 1, 1).EntireRow.Delete
E = E - 1
Wend
t = 0
n = n + 1
Else
t = 0
n = n + 1
End If
Else
If t < Cells(n, 10).Value Then
If Cells(n + 1, 1).Value <> Cells(n, 1).Value Then
n = n + 1
t = 0
Cells(n, 14).Value = "masalah"
End If
End If
End If
Next
End Sub
Sub Format2Invoice()
'
' Format2Invoice Macro
' Macro recorded 2/11/04 by Setiono
'
Workbooks.Open FileName:= _
"D:\Documents & Settings\Job\Vendor\1110030 - Sanyo Semiconductor (S) Pte, Ltd\PO LIST\PART LIST & PRICE.xls"
ActiveWindow.ActivateNext
Rows("2:8").Delete Shift:=xlUp
Range("I1").Cut Destination:=Range("A1")
Rows("2:5").Insert Shift:=xlDown
Columns("A:A").Insert Shift:=xlToRight
Cells(6, 2).Select
Selection.End(xlDown).Select
Range(Cells(6, 2), Cells(ActiveCell.Row, ActiveCell.Column)).Insert Shift:=xlToRight
Range("B4").Select
ActiveCell.FormulaR1C1 = "INVOICE NO."
Range("C4").Select
ActiveCell.FormulaR1C1 = "PART CODE"
Columns("B:B").ColumnWidth = 12
Columns("C:C").ColumnWidth = 20.43
Columns("E:E").ColumnWidth = 11.14
Columns("H:J").Delete Shift:=xlToLeft
Columns("G:G").Delete Shift:=xlToLeft
Columns("D:D").Insert Shift:=xlToRight
Range("D4").Select
ActiveCell.FormulaR1C1 = "DESCRIPTION"
Columns("H:H").Cut
Columns("E:E").Insert Shift:=xlToRight
Range("E4").Select
ActiveCell.FormulaR1C1 = "QTY"
Columns("F:F").Insert Shift:=xlToRight
Range("F4").Select
ActiveCell.FormulaR1C1 = "PRICE"
Columns("G:G").Insert Shift:=xlToRight
Range("G4").Select
ActiveCell.FormulaR1C1 = "AMOUNT"
Range("H4").Select
ActiveCell.FormulaR1C1 = "MODEL/LOT"
Range("I4").Select
ActiveCell.FormulaR1C1 = "P/O NO."
Range("J4").Select
ActiveCell.FormulaR1C1 = "REMARKS"
Columns("F:F").Insert Shift:=xlToRight
Columns("F:F").ColumnWidth = 2.86
Columns("A:A").ColumnWidth = 1.71
Columns("I:I").ColumnWidth = 11.71
Columns("E:E").ColumnWidth = 7.14
Range("D6").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[PART LIST & PRICE.xls]18-FEB-2003 (2)'!R8C1:R100C2,2,FALSE)"
Cells(6, 3).Select
Selection.End(xlDown).Select
Range(Cells(6, 4), Cells(ActiveCell.Row, 4)).FillDown
Range("G6").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-4],'[PART LIST & PRICE.xls]18-FEB-2003 (2)'!R8C1:R100C3,3,FALSE)"
Range("G6").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-4],'[PART LIST & PRICE.xls]18-FEB-2003 (2)'!R8C1:R100C3,3,FALSE)"
Range("G6").Select
Selection.NumberFormat = "#,##0.0000"
Range("E6:E364").Select
Selection.End(xlDown).Select
Range("G6:G364").Select
Range("G364").Activate
Selection.FillDown
Selection.End(xlUp).Select
Range("H6").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-3]"
Range("G6:G364").Select
Selection.End(xlDown).Select
Range("H6:H364").Select
Range("H364").Activate
Selection.FillDown
Selection.NumberFormat = "#,##0.00"
Sheets("Tsfsplf").Name = "Sheet1"
ActiveWorkbook.Save
Range("A1").Select
End Sub
Sub Split_Number_fr_Text()
'
' Split_Number_fr_Text Macro
' Macro recorded 12/6/2006 by sanyo
'
For c = 1 To 65535
If Cells(c, ActiveCell.Column) = "" Then Exit For
Next c
a = 0
a = Val(InputBox("Hasilnya taro di kolom berapa?"))
For x = 1 To c
brs = ActiveCell.Row
kol = ActiveCell.Column
kal = Cells(brs, kol)
n = Len(Cells(brs, kol))
kal_n = ""
kal_text = ""
For L = 1 To n
kal_n = Mid(kal, L, 1)
Select Case kal_n
Case 0 To 9
kal_text = Left(kal, L - 2)
Exit For
Case Else
End Select
Next L
Cells(brs, a) = kal_text
brs = brs + 1
kal_text = ""
Cells(brs, kol).Select
Next x
'
End Sub
Sub ClearSpace()
'
' ClearSpace Macro
'
'
Selection.End(xlDown).Select
Y = ActiveCell.Row
x = ActiveCell.Column
For n = 1 To Y
t = Trim(Cells(n, x).Value)
Cells(n, x).Value = t
Next n
End Sub
Sub LinkPlanningSched2DLVSCHD()
'
' Macro5 Macro
'
Dim tgl As String
'On Error Resume Next
'tgl = Format(DateSerial(Year(Now()), Month(Now()), Day(Now())), "dd-mmm-yy")
For n = 1 To 65000
If Cells(n, 5) <> "" Then
Cells(n, 8).Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-4],'[DLVSCH_1110460_03-Jun-09.xls]FINAL'!R2C1:R3720C12,12,FALSE)"
ActiveCell.Select
Selection.NumberFormat = "[$-409]d-mmm-yy;@"
Cells(n, 9).Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-5],'[DLVSCH_1110460_03-Jun-09.xls]FINAL'!R2C1:R3720C11,11,FALSE)"
ActiveCell.Select
Selection.NumberFormat = "General"
Cells(n, 10).Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-6],'[DLVSCH_1110460_03-Jun-09.xls]FINAL'!R2C1:R3720C19,19,FALSE)"
ActiveCell.Select
Selection.NumberFormat = "General"
End If
Next n
End Sub
Sub SplitDifferentMonth()
'
' Split Diffrent Item Macro base on ActiveCell Position
' Macro recorded 10/9/02 by Setiono
'
'
Dim Y1Cell As Long, X1Cell As Long
X1Cell = ActiveCell.Column
Y1Cell = ActiveCell.Row
SplitMonth Y1Cell, X1Cell
End Sub
Sub SplitMonth(FirstRow As Long, DiffCol As Long)
'Remove space on Active Cell Column
p = IsEOF(FirstRow, DiffCol)
Range(Cells(FirstRow, DiffCol), Cells(p, DiffCol)).Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
FirstRow = FirstRow + 1
For n = FirstRow To p
If Month(Cells(n, DiffCol)) <> Month(Cells(n - 1, DiffCol)) Then
c = c + 1
End If
Next n
For n = FirstRow To p + c
If Month(Cells(n, DiffCol)) <> Month(Cells(n - 1, DiffCol)) Then
Cells(n, DiffCol).EntireRow.Insert
'Rows(n).RowHeight = 10
'Range(Cells(n, 1), Cells(n, 14)).Borders(xlInsideVertical).LineStyle = xlNone
'Range(Cells(n, 1), Cells(n, 14)).Interior.ColorIndex = xlNone
n = n + 1
End If
Next n
End Sub
Sub EraseColG()
For n = 7 To 745
Cells(n, 7).Select
If Cells(n, 7).Value = "---" Or Cells(n, 7).Value = "" Or Cells(n, 7).Value = "___" Then
While Cells(n, 7).Value = "---" Or Cells(n, 7).Value = "" Or Cells(n, 7).Value = "___"
Cells(n, 7).EntireRow.Delete
Wend
End If
Next
End Sub
Sub TransPosePaste()
'
' TransPosePaste Macro
'
'
Range("J6:L7").Select
Selection.Copy
Range("A15").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
Are you trying to earn money from your traffic via popup ads?
BalasHapusIn case you are, have you tried using PopAds?