Install Visual Basic 6 (VB6) on Windows 7 / 8 / 10

You may be wondering, Why install Visual Basic 6 on the new operating systems such as windows 7 or Windows 8.
Well, VB6 is the best tool for learning GUI programming in Windows (according to my teachers in college..!!). But they never tell how to install them on newer operating operating systems. So i figured it out myself.
This has been successfully tested on my Windows 8 64-bit, so it should probably work with Windows 7 too.
So here are the steps which I followed

1. Create a zero-byte file in C:\Windows named MSJAVA.DLL. The reason for this is that the setup will look for this file and if it doesn’t find it, it will force for installation of very old version of Java (which wont install on Windows 8) and will force reboot too. By creating a zero-byte file, the Java installation is bypassed, and no reboot is required.
   For those who are wondering how to create a zero-byte file here is a simple process.
   • Type cmd in Start Menu -> Right click on cmd.exe -> select “Run as administrator” and type in the foll command
     copy nul C:\Windows\msjava.dll
2. Now insert your Visual Studio 6 CD (or extract the given file to a folder on Desktop)
3. Exit from Autorun (In case of CD)
4. Browse to the root folder of CD (or the extracted folder on Desktop)
5. Right Click “SETUP.EXE” -> Properties -> Compatibility Tab
6. Now Check “Run this program in compatibility mode” and Select Windows XP( Service Pack 3)
7. Also Check “Run this program as Administrator” and Click OK
8. Now open SETUP.EXE. UAC will prompt for confirmation. Select Yes
9. Now some Program Compatibility Assistant warnings might appear. Select Run Program There
10. Click Next -> Click “I accept agreement”, then Next -> Enter name and company information, click Next
11. Now Select “Custom Setup” (IMPORTANT). Click Next
12. Click Continue, then OK
13. Now Setup Will Wait and process some information. It might also go to “Not responding” State and Windows might Prompt to close the Process. DO NOT close the process.(IMPORTANT)  Select “Wait for the program to respond”.
    Wait time varies, I had to wait for 30-45 mins on “Not Responding” State. You might need to wait more…or less if you are lucky
14. Now finally the options list appears
15. Click on “Select All”. All options should be checked. Click Continue, setup will continue.
16. Now Setup might again Hang on “Updating System”. Wait, DO NOT close the process. Again the wait time might be from few mins to an hour..!!
17. Finally, a successful completion dialog will appear, at which click OK. At this point, Visual Basic 6 is installed. Some people might also get some error, but Visual Basic 6 will be installed anyways.
18. Access it from Start Menu

Update: Some of my friends mentioned about he sluggishness of VB6 on Windows 8. For example the resizing of objects. Here is a quick fix

1. Using Windows Explorer, browse the location where you installed VB6. By default, the path is:
   C:\Program Files (x86)\Microsoft Visual Studio\VB98
2. Right click the VB6.exe program file, and select properties from the context menu.
3. Click on compatibility tab
4. Check the foll checkboxes:
   For Windows 7:
   • Run this program in compatibility mode for Windows XP (Service Pack 3)
   • Disable Visual Themes
   • Disable Desktop Composition
   • Disable display scaling on high DPI settings
   For Windows 8
   
   • Run this program in compatibility mode for Windows XP (Service Pack 3)
   • Reduced Color Mode (16-Bit Color)
   • Disable display scaling on high DPI settings
5. After saving open up VB6, It should work normally

Happy Programming..!!

Macro I build when I was in SEI

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