Option Explicit
Dim stFormatStyle, stResult As String
Dim iStart, iEnd, iDigitsAfterDecimalPoint, iDecimals As Integer
Dim bIsPercentage As Boolean

Sub PP3InputRefV2()

'#############################################################################################################
'JS 05/05/2011
'Creates and populates the Input Reference table for Honda Germany Profit Planner iii
'#############################################################################################################

Dim StrFldr, c00, stCurrentStyle, bVNum, bImport, bVImport As String
Dim bSuggestvImport, bSuggestVNum As Integer
Dim PPWB, PPNew, PPOld As Workbook
Dim PPNewIR, PPWBForm As Worksheet
Dim Nrow, NCol As Long
Dim cell, cells As Range
Dim sq, sht, sht2 As Variant
Dim Startime, Endtime As Double

'Gather Inport and Convert version numbers and determine if manually data is to be imported
bVNum = Application.InputBox("Please enter the version number you wish to convert", "Version convert Entry Box", bSuggestVNum)
bImport = MsgBox("Do you want to import old version?", vbQuestion + vbYesNo, "???")
    If bImport = vbYes Then 'if user selects yes it will ask what version they want to use
        bVImport = Application.InputBox("What version do you want to import", "Year Entry Box", bSuggestvImport)
    End If
    
Startime = Timer

'Define Variables
StrFldr = "R:\HondaCarsEurope\Markets\Germany\PPIII\Tables"
Set PPWB = Workbooks.Open(StrFldr & "\" & "HDE_PPIII_MONTH_Input_Reference_Form_V" & bVNum & ".xlsx")
Set PPWBForm = PPWB.Sheets("PPIIIFORM")
Set PPNew = Application.Workbooks.Add
PPNew.Sheets.Add.Name = ("InputRefAPD")
Set PPNewIR = PPNew.Sheets("InputRefAPD")

'Add headerlines to Input Reference sheet
PPNewIR.Select
NCol = 1
PPNewIR.cells(NCol, 1).Resize(, 25).Value = Array("InputReference", "Department", "Category", "Section", "DeptVisible", "InputReferenceOrder", _
"LineReference", "LineDescription", "InputDescription", "Format", "Currency", "ColPos", "Input", "InPP", _
"FormulaOverwrite", "Seasonal", "Divide", "Equals", "SectionOverwrite", "LineDescriptionOverwrite", _
"LineJumpReference", "LineJumpText", "HelpText", "ValidationOrder", "Benchmark")

'Loop through cell range in Form and populate Input Reference table
Nrow = 2
For Each cell In PPWBForm.Range("F4:U644")
    If cell.Value <> "" Then
        PPNewIR.cells(Nrow, 1).Value = cell.Value
        PPNewIR.cells(Nrow, 2).Value = PPWBForm.Range("A" & cell.Row)
        PPNewIR.cells(Nrow, 3).Value = PPWBForm.Range("B" & cell.Row)
        PPNewIR.cells(Nrow, 4).Value = PPWBForm.Range("C" & cell.Row)
        PPNewIR.cells(Nrow, 5).Value = "True"
        PPNewIR.cells(Nrow, 7).Value = PPWBForm.Range("D" & cell.Row)
        PPNewIR.cells(Nrow, 8).Value = PPWBForm.Range("E" & cell.Row)
        PPNewIR.cells(Nrow, 10).Value = PPWBForm.Range("E" & cell.Row).Value & " - " & PPWBForm.Range(Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZ", cell.column, 1) & "1").Value
        PPNewIR.cells(Nrow, 11).Value = fTryThis(cell)        PPNewIR.cells(Nrow, 12).Value = cell.column - 5
        PPNewIR.cells(Nrow, 13).Value = Not cell.Interior.Color = RGB(217, 217, 217)
        PPNewIR.cells(Nrow, 14).Value = "True"
        PPNewIR.cells(Nrow, 15).Value = cell.Interior.Color = RGB(255, 255, 0)
        PPNewIR.cells(Nrow, 16).Value = PPWBForm.Range("V" & cell.Row)
        PPNewIR.cells(Nrow, 17).Value = PPWBForm.Range("W" & cell.Row).Value
        PPNewIR.cells(Nrow, 18).Value = PPWBForm.Range("X" & cell.Row).Value
        PPNewIR.cells(Nrow, 19).Value = PPWBForm.Range("Y" & cell.Row).Value
        PPNewIR.cells(Nrow, 20).Value = PPWBForm.Range("Z" & cell.Row).Value
        PPNewIR.cells(Nrow, 21).Value = PPWBForm.Range("AA" & cell.Row).Value
        PPNewIR.cells(Nrow, 22).Value = PPWBForm.Range("AB" & cell.Row).Value
        Nrow = Nrow + 1
        Application.StatusBar = cell.Address
    End If
    
Next cell

PPWB.Close

If bImport = vbYes Then 'if the user selected yes to the question at the start
    'Opens perious version doc entered and copy data into temp sheet and closes it
    Application.StatusBar = "Importing previous version data"
    Set PPOld = Workbooks.Open(StrFldr & "\" & "HDE_PPIII_MONTH_Input_Reference_Form_V" & bVImport & ".xlsx")
    PPNew.Sheets.Add.Name = "ConvertManual"
    PPOld.Sheets("InputRefapd").cells.Copy Destination:=PPNew.Sheets("ConvertManual").Range("A1")
    PPOld.Close
    'Loops through column in
    For Each cell In PPNewIR.Range("A2:A3000")
        If cell.Value <> "" Then
          PPNewIR.cells(Nrow, 6).Value = Application.WorksheetFunction.VLookup(cell.Value, PPNew.Sheets("ConvertManual").Range("A2:Y3000"), 10, False)
          PPNewIR.cells(Nrow, 10).Value = Application.WorksheetFunction.VLookup(cell.Value, PPNew.Sheets("ConvertManual").Range("A2:Y3000"), 10, False)
          PPNewIR.cells(Nrow, 21).Value = Application.WorksheetFunction.VLookup(cell.Value, PPNew.Sheets("ConvertManual").Range("A2:Y3000"), 21, False)
          PPNewIR.cells(Nrow, 22).Value = Application.WorksheetFunction.VLookup(cell.Value, PPNew.Sheets("ConvertManual").Range("A2:Y3000"), 22, False)
          PPNewIR.cells(Nrow, 23).Value = Application.WorksheetFunction.VLookup(cell.Value, PPNew.Sheets("ConvertManual").Range("A2:Y3000"), 23, False)
        End If
        Application.StatusBar = cell.Address
    Next cell
Application.StatusBar = "Formatting and deleteing temporary Sheet"
PPNewIR.Select: PPNewIR.cells.Copy: PPNewIR.PasteSpecial Paste:=xlPasteValues
PPNew.Sheets("ConvertManual").Delete
End If

Application.StatusBar = "Formatting"
PPNewIR.Select: PPNewIR.cells.Copy: PPNewIR.Range("A1").Select: Selection.PasteSpecial Paste:=xlPasteValues
For Each sht2 In Array("Sheet1", "InputRefapd")
    PPNew.Sheets(sht2).Select: Range("A1").Select
Next

Application.StatusBar = "Saving"
PPNew.SaveAs StrFldr & "\" & "HDE_PPIII_Input_Reference_Table_MONTH_" & bVNum & ".xlsx"

Endtime = Timer - Startime
Application.StatusBar = "Macro Finished in " & Endtime
End Sub
Function fTryThis(Target As Range) As String

    'reset iDigitsAfterDecimalPoint
    iDigitsAfterDecimalPoint = 0
    
    'get the formatting style for the cell
    stFormatStyle = Target.NumberFormat
    
    'if the format style is "general", return the default string and exit the function
    If stFormatStyle = "General" Then
        fTryThis = "%10.0f%%"
        Exit Function
    End If
    
    'if the format style is "comma", find the number of digits after decimal and return the string
    'this is what the NumberFormat string looks like for a "comma" format:
        '   _(* #,##0.00_);_(* (#,##0.00);_(* "-"??_);_(@_)
    If InStr(stFormatStyle, "#,##") Then
        'find the period
        iStart = InStr(stFormatStyle, ".")
        'find the ending 0
        iEnd = InStr(iStart, stFormatStyle, "_")
        'subtract the two to get the number of digits after the period
        iDigitsAfterDecimalPoint = iEnd - iStart - 1
        'return the string
        fTryThis = "%10." & iDigitsAfterDecimalPoint & "f%"
        'exit the function
        Exit Function
    End If
    
    'this looks at the last character of the NumberFormat string and if it's a percentage sign, then sets a Boolean to true (this will be used later to put an extra "%" sign on the return string if need be
    If Right(stFormatStyle, 1) = "%" Then
         bIsPercentage = True
    Else
         bIsPercentage = False
    End If
    'find the decimal point position:
    iStart = InStr(stFormatStyle, ".")
    
    If iStart = 0 Then 'there is no period
        iDigitsAfterDecimalPoint = 0
    Else 'there is a period
        iDigitsAfterDecimalPoint = Len(stFormatStyle) - iStart
    End If
    
    'if it's a percentage format with digits after period, subtract one to account for the "%" sign
    If bIsPercentage And iStart > 0 Then
        If bIsPercentage Then iDigitsAfterDecimalPoint = iDigitsAfterDecimalPoint - 1
    End If
    'Now you should have all the pieces you need so just put it together:
    stResult = "%10." & iDigitsAfterDecimalPoint & "f%"
    If bIsPercentage Then stResult = stResult & "%"
    
    'return the string
    fTryThis = stResult
End Function

'here cell is a variant
Dim cell, cells As Range

'try this:
Dim cell as range, cells As Range