convert .wq1 to .xlsm

buzz71023 · Dec 9, 2015

I have A LOT of files that are in WQ1 format. I have a spreadsheet template (called MASTERREV12 that has very, very, long code that allows you select the file you want to open and import into this template (allowing you to save it as a different filename and not overwrite the MASTERREV12). Well since .WQ1 files are no longer compatible with Excel 2007 and up and I'm having to run 2003 and 2013 side by side. I would like to be able to just run 2013. First thought is can someone help me convert these to .xlsm? I'm okay with convert one at time if need be.

For the sake of all the information being out there, that very, very, long code that the template uses to import the file is below. If you think this can be done by adding a different code, I'm good with that.(I think a lot of it is repetitive actions)

DATA HAS TO TRANFER CORRECTLY! IT IS VERY CRITICAL!

Code:

Dim ACTUALDATA(201, 1) As Variant
Dim JOBNUMR(201, 1) As Long
Dim DATER(201, 1) As Date
Dim DATIME(201, 1) As String
Dim PACKAGE(201, 1) As Variant
Dim LINER(201, 1) As Variant
Dim CUSTOMER(201, 1) As Variant
Dim HEADER(50, 3) As String
Dim INFOLOCAL(10, 2) As String
Dim FNDROW(6, 3) As String
Dim C As Variant
Dim C2 As Variant
Dim C3 As Variant
Dim C4 As Variant
Dim PSDVAL As Variant
Dim TARGVAL As Variant
Dim UPSPEC As Variant
Dim LOSPEC As Variant
Dim AVGVAL As Variant
Dim FRED As Integer
Dim FRED2 As Integer
Dim FRED3 As Integer
Dim FRED4 As Integer

Dim COMFORT As String
Dim MASTERNAME As String
Dim L As String
Dim AVGROW As String
Dim STDEVROW As String
Dim DATAPTSROW As String
Dim UPROW As String
Dim LOROW As String
Dim MAXROW As String
Dim MINROW As String
Dim RANGEROW As String
Dim TARGROW As String
Dim WORKDRIVE As String
Dim FLOPPYDRIVE As String
Dim VIEWSET As String
Dim NAMEFILE As String
Dim COMPILEQ As String
Dim JOBID As String
Dim EXTENSION As String
Dim ANYEXT As String
Dim FILENAME2 As String
Dim DETERMINE As String
Dim FILENAME3 As String
Dim LETTERS As String
Dim LETTERS2 As String
Dim SHEETNAME As String
Dim LCTN As String
Dim JOB As String
Dim PCODE As String
Dim STANLOCAL As String
Dim STANDARD As String
Dim DTROWA As String
Dim DTROWB As String
Dim DTROWC As String
Dim DTROWD As String
Dim DTROWE As String
Dim DTROWF As String
Dim CURRCOL As String
Dim INDICENAME As String
Dim WATCHER As String
Dim WATCHER1 As String
Dim WATCHER2 As String
Dim MCURRCOL As String
Dim TSTMETH As String
Dim DECI1 As String
Dim DECIVAL As String
Dim DECICH As String
Dim DTROW As String
Dim MDTROW As String
Dim LST1 As String
Dim LASTCOL1 As String
Dim LASTFORM As String
Dim LASTCHK1 As String
Dim LASTCHK As String
Dim LASTCOL As String
Dim LST As String
Dim SECLASTCOL As String
Dim FORMATTER As String
Dim FORMCHCK As String

Dim FIRSTER As Integer
Dim newbe As Integer
Dim Q As Integer
Dim QUERY As Integer
Dim FLOPPYIMP As Integer
Dim N As Integer
Dim RESPONSE As Integer
Dim HEADLOCAL As Integer
Dim DIFFERBOY As Integer
Dim DIFFERBOY2 As Integer
Dim L2 As Integer
Dim WOW As Integer
Dim THRU As Integer
Dim X As Integer
Dim V As Integer
Dim VA As Integer
Dim VB As Integer
Dim VC As Integer
Dim VD As Integer
Dim VE As Integer
Dim VF As Integer
Dim DATAROW As Integer
Dim DATAROWA As Integer
Dim DATAROWB As Integer
Dim DATAROWC As Integer
Dim DATAROWD As Integer
Dim DATAROWE As Integer
Dim DATAROWF As Integer
Dim K As Integer
Dim STARTER As Integer
Dim STARTER2 As Integer
Dim STARTER3 As Integer
Dim STARTER4 As Integer
Dim NEXTCOL As Integer
Dim DATACHCK As Variant
Dim W As Integer
Dim MDATAROW As Variant
Dim LENNAME As Integer
Dim LNGTH As Integer
Dim BUFFY As Integer
Dim BLANK As Integer
Dim H As Integer
Dim DECILN As Integer
Dim DECIFORM As Integer
Dim ENDER As Integer
Dim MOTIF As Integer
Dim FORMATER As Integer
Dim FRMAT As Integer

Sub EXPERTIMPORT()
'
' EXPERTIMPORT Macro
' Macro created 9/22/99 by Fred Low
'
'   OVERVIEW:   IMPORTS DATA INTO EXCEL SPREADSHEET
'               FROM PREVIOUSLY SAVED EXCEL SPREADSHEET
'               CREATED BY USING "MASTER"
'
'   ACTION: 1.  SETS UP THREE MATRICES:
'               HEADER(X, 0) -  CONTAINS INDICE TITLES,
'               HEADER(X, 1) -  DESTINATION COLUMN ADDRESSES IN "MASTER"
'               HEADER(X, 2) -  GETS POPULATED W/ COLUMN ADDRESSES FOR
'                               INDICE IN QPRO WORKSHEET.
'               INFOLOCAL(X, 0) -   CONTAINS SPECIFIC INFO TO SEARCH
'                                   FOR IN QPRO WORKSHEET (LOCAL, P-CODE, ETC.)
'               INFOLOCAL(X, 1) -   GETS POPULATED W/ ADDRESS
'                                   CORRESPONDING TO INFO IN (X, 0)
'               FNDROW(X, 0) -  CONTAINS INFO TO SEARCH FOR IN QPRO WORKSHEET
'               FNDROW(X, 1) -  GETS POPULATED W/ ROW ADDRESS FOR
'                               INFO IN (X, 0)
'           2.  ASKS WHERE FILE IS LOCATED
'           3.  OPENS APPROPRIATE FILE
'           4.  SETS EXCEL CALCULATION OPTION TO AUTO
'           5.  CREATES 'SHEET1' AND PASTES WORKING COPY
'               OF DATA And HEADER 'REGION'
'           6.  USES 'FIND' FUNCTION TO POPULATE MATRICES
'           7.  COPY/PASTE INFO AND DATA TO 'MASTER' WORKBOOK
'               IF THERE ARE DATA POINTS IN THE COLUMN OR
'               THERE IS NO 'DATA POINTS' VALUE (LIKE "HMIS REQ?")
'               *SPECIAL CASE:  MOVES COMMENT COLUMNS WITH
'                   ASH, MI, AND DISP DATA ONLY
'           8.  DELETES 'SET-UP', 'IMPORT' AND 'TRANSFER'
'               BUTTONS
'           9.  CALLS 'COMPILE' SUB
'           10. CALLS 'SAVE_FILE' SUB
'           11. CLOSES .WK1 FILE
'

MASTERNAME = ActiveWorkbook.Name
Range("A228") = MASTERNAME


'SET UP MATRICES FOR DATA TRANSFER
'POPULATE 'HEADER MATRIX' WITH INFO FROM 'IMPORT INDICE' SHEET
    FIRSTER = 0
    newbe = 0
    Q = 0
    L = Q + 2
    
    Sheets("DATA").Select
    
    INFOLOCAL(8, 0) = "CODE"
    INFOLOCAL(8, 1) = "B4"
    INFOLOCAL(9, 0) = "STD"
    INFOLOCAL(9, 1) = "B11"
    
    FNDROW(0, 0) = "PROC STD"
    FNDROW(1, 0) = "TARG"
    FNDROW(2, 0) = "UPPER"
    FNDROW(3, 0) = "LOWER"
    FNDROW(4, 0) = "DATA POINTS"
    FNDROW(0, 1) = "$6"
    FNDROW(1, 1) = "$4"
    FNDROW(2, 1) = "$10"
    FNDROW(3, 1) = "$11"


    'DEFINE ROWS IN MASTER
    AVGROW = "5"
    STDEVROW = "8"
    DATAPTSROW = "9"
    UPROW = "10"
    LOROW = "11"
    MAXROW = "12"
    MINROW = "13"
    RANGEROW = "14"
    TARGROW = "4"
    
    'SET UP 'HARD DRIVE' AND FLOPPY ADDRESSES
    Worksheets("SETUP_DATA").Select
    WORKDRIVE = Range("B19")
    FLOPPYDRIVE = Range("B30")
    VIEWSET = Range("B25")
    NAMEFILE = Range("B24")
    COMPILEQ = Range("B32")
    JOBID = Range("B18")
    Worksheets("DATA").Select

    'OPEN FILE DIALOG BOX

    QUERY = MsgBox("IS FILE ON DISK? (Drive " + FLOPPYDRIVE + ":\)", 4)
WRONG:
    FLOPPYIMP = 0
    If QUERY = 6 Then
        FLOPPYIMP = 1
        ChDrive FLOPPYDRIVE + ":\"
        ChDir FLOPPYDRIVE + ":\"
    Else
        ChDrive WORKDRIVE + "\"
        ChDir WORKDRIVE + "\"
    End If
    FileName = Application.GetOpenFilename
    EXTENSION = Right(FileName, 4)
    ANYEXT = Left(EXTENSION, 1)
    If FileName = False Then
        MsgBox ("MACRO TERMINATED")
        GoTo TERMINATE:
    End If
    
    'OPEN .WK1 FILE
    Workbooks.Open FileName:=FileName, UpdateLinks:=0
    
    'SWITCH TO WORKSHEET TO BE TRANSFERED FROM
    
    'GET FILENAME W/O DIRECTORY
    N% = 4
CHECK:
    FILENAME2 = Right(FileName, N%)
    DETERMINE = Left(FILENAME2, 1)
    If DETERMINE <> "\" Then
        N% = N% + 1
        GoTo CHECK:
    End If
    
    'GET FILENAME W/O EXTENSION AND NAME OF DATASHEET
    If DETERMINE = "\" Then
        N% = N% - 1
        FILENAME3 = Right(FileName, N%)
        LETTERS = Len(FILENAME3)
        LETTERS2 = LETTERS - 4
        SHEETNAME = Left(FILENAME3, LETTERS2)
    End If
    
    'FIND IF ROW 19 CONTAINS HEADER INFO
    FRED4 = 0
    With Worksheets(1).Range("A11:A22")
        Set C4 = .Find(JOBID, lookin:=xlValues)
        If C4 Is Nothing Then
            FRED4 = 100
        End If
    End With
    If FRED4 = 100 Then
        RESPONSE = MsgBox("Program could not find Row with header info." + Chr(13) + "Unable to import file.", 0, "PROBLEM")
        GoTo TERMINATE:
    End If
    With Worksheets(1).Range("A11:A22")
        .Find(WHAT:=JOBID, lookin:=xlValues, LookAt:= _
                xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False) _
                .Select
        HEADLOCAL = Selection.End(xlToRight).Row
    End With
    If HEADLOCAL < 19 Then
        DIFFERBOY = 19 - HEADLOCAL
        L = 0
        Do While L < DIFFERBOY
            Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            L = L + 1
        Loop
    End If
    If HEADLOCAL > 19 Then
        DIFFERBOY2 = HEADLOCAL - 19
        L2 = 0
        Do While L < DIFFERBOY
            Rows("1:1").Select
            Selection.Delete Shift:=xlUp
            L2 = L2 + 1
        Loop
    End If

    'FIND IF FIRST RUN
    Range("A19").Select
    WOW = Selection.End(xlDown).Row
    If WOW > 219 Then
        newbe = 5
    End If
    
    'FIND SITE DATA ORIGINATED FROM AND SET = TO LCTN
        LCTN = Range("A8")
        Range("A1").Select
        
    'FIND PRODUCT CODE AND SET  = TO PCODE
    On Error Resume Next:
            Cells.Find(WHAT:=INFOLOCAL(8, 0), AFTER:=ActiveCell, lookin:=xlValues, LookAt:= _
                    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False) _
                    .Select
'            Selection.End(xlToRight).Activate
'            CODELOCAL = ActiveCell.Address
            CODELOCAL = Selection.End(xlToRight).Address
    On Error GoTo 0
        Range("A1").Select
        PCODE = Range(CODELOCAL)
    
    'FIND LAST JOB ON SHEET AND SET IT = TO JOB
    Range("A220").Select
    THRU = Selection.End(xlUp).Row
    'If THRU = 19 And FLOPPYIMP = 0 Then
    If THRU = 19 Then
        JOB = Range("B6")
    Else
        JOB = Cells(THRU, 1)
    End If
    
    'FIND STANDARD IF ITS THERE AND SET = TO STANDARD
    FRED3 = 0
    With Worksheets(1).Range("A11:C18")
        Set C3 = .Find(INFOLOCAL(9, 0), lookin:=xlValues)
        If C3 Is Nothing Then
            FRED3 = 100
        End If
    End With
    If FRED3 = 100 Then GoTo NOTHERE:
    With Worksheets(1).Range("A11:C18")
        .Find(WHAT:=INFOLOCAL(9, 0), lookin:=xlValues, LookAt:= _
                xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False) _
                .Select
'        Selection.End(xlToRight).Activate
'        STANLOCAL = ActiveCell.Address
        STANLOCAL = Selection.End(xlToRight).Address
        STANDARD = Range(STANLOCAL)
        If Len(STANDARD) > 8 Then
            STANDARD = ""
        End If
    End With
NOTHERE:
    Range("A1").Select
    
    'FIND ROWS CONTAINING PSD, TARG, SPECS, AND # OF DATA POINTS
    X = 0
    Do While X < 6
        On Error Resume Next:
        FRED2 = 0
        With Worksheets(1).Range("F1:F18")
            Set C2 = .Find(FNDROW(X, 0), lookin:=xlValues)
            If C2 Is Nothing Then
                FRED2 = 100
            End If
        End With
            If FRED2 = 100 Then GoTo BOO2:
            FNDROW(X, 2) = Cells.Find(WHAT:=FNDROW(X, 0), AFTER:=ActiveCell, lookin:=xlValues, LookAt:= _
                    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _
                    .Row

BOO2:
        On Error GoTo 0
        X = X + 1
        Range("A1").Select
    Loop
    

    'POPULATE MATRICES FOR FIRST FOUR COLUMNS
    VA = 0
    DATAROWA = 21
    Do While VA < 200
        DTROWA = DATAROWA
        If Range("A" + DTROWA) <> " " And Range("A" + DTROWA) <> "" And IsNumeric(Range("A" + DTROWA)) = True Then
            JOBNUMR(VA, 1) = Range("A" + DTROWA)
        End If
        VA = VA + 1
        DATAROWA = DATAROWA + 1
    Loop
    VB = 0
    DATAROWB = 21
    Do While VB < 200
        DTROWB = DATAROWB
        If Range("B" + DTROWB) <> " " And Range("B" + DTROWB) <> "" And IsDate(Range("B" + DTROWB)) = True Then
            DATER(VB, 1) = Range("B" + DTROWB)
        End If
        VB = VB + 1
        DATAROWB = DATAROWB + 1
    Loop
    VC = 0
    DATAROWC = 21
    Do While VC < 200
        DTROWC = DATAROWC
        If Range("C" + DTROWC) <> " " And Range("C" + DTROWC) <> "" Then
            DATIME(VC, 1) = Range("C" + DTROWC)
        End If
        VC = VC + 1
        DATAROWC = DATAROWC + 1
    Loop
    VD = 0
    DATAROWD = 21
    Do While VD < 200
        DTROWD = DATAROWD
        If Range("D" + DTROWD) <> " " And Range("D" + DTROWD) <> "" Then
            PACKAGE(VD, 1) = Range("D" + DTROWD)
        End If
        VD = VD + 1
        DATAROWD = DATAROWD + 1
    Loop
    VE = 0
    DATAROWE = 21
    Do While VE < 200
        DTROWE = DATAROWE
        If Range("E" + DTROWE) <> " " And Range("E" + DTROWE) <> "" Then
            LINER(VE, 1) = Range("E" + DTROWE)
        End If
        VE = VE + 1
        DATAROWE = DATAROWE + 1
    Loop
    VF = 0
    DATAROWF = 21
    Do While VF < 200
        DTROWF = DATAROWF
        If Range("F" + DTROWF) <> " " And Range("F" + DTROWF) <> "" Then
            CUSTOMER(VF, 1) = Range("F" + DTROWF)
        End If
        VF = VF + 1
        DATAROWF = DATAROWF + 1
    Loop
    'DONE WITH FIRST 5 COLUMNS MATRICES
    
    'FIND CURRENT COLUMN IN SAVED FILE
    K = 0
    L = 0
    STARTER = Asc("G")
    STARTER2 = Asc("A")
INDICE:
    If K > 45 Then GoTo NOMO:
    If K = 0 Then
        INDICENAME = Range("G19")
        CURRCOL = "G"
    Else
        If K < 20 Then
            NEXTCOL = STARTER + K
            CURRCOL = Chr(NEXTCOL)
            INDICENAME = Range(CURRCOL + "19")
        Else
            NEXTCOL = STARTER2 + (K - 20)
            CURRCOL = "A" + Chr(NEXTCOL)
            INDICENAME = Range(CURRCOL + "19")
        End If
    End If

    Range(CURRCOL + "19").Select
    DATACHCK = Selection.End(xlDown).Row
    'CHECK INDICENAME FOR SPACES ON THE ENDS
    LENNAME = Len(INDICENAME)
NAMESPACEL:
    If Left(INDICENAME, 1) = " " Then
        LENNAME = LENNAME - 1
        INDICENAME = Right(INDICENAME, LENNAME)
        GoTo NAMESPACEL:
    End If
    LENNAME = Len(INDICENAME)
NAMESPACER:
    If Right(INDICENAME, 1) = " " Then
        LENNAME = LENNAME - 1
        INDICENAME = Left(INDICENAME, LENNAME)
        GoTo NAMESPACER:
    End If

    'CHECK FOR SPACE IN INDICENAME
    'IF SPACE THERE REPLACE WITH "_"
    LNGTH = Len(INDICENAME)
    BUFFY = 1
    Do While BUFFY < LNGTH + 1
        WATCHER = Mid(INDICENAME, BUFFY, 1)
        WATCHER1 = Left(INDICENAME, BUFFY - 1)
        WATCHER2 = Right(INDICENAME, LNGTH - BUFFY)
        
        If WATCHER = " " Then
            WATCHER = "_"
            INDICENAME = WATCHER1 + WATCHER + WATCHER2
        End If
        BUFFY = BUFFY + 1
    Loop

    If newbe = 0 Then
    'CHECK TO SEE IF THERE IS DATA IN THE COLUMN
        If DATACHCK > 221 Then
            K = K + 1
            GoTo INDICE
        End If
    End If
    
    If INDICENAME = "" Then
        K = K + 1
        BLANK = BLANK + 1
        If BLANK > 2 Then GoTo NOMO:
        GoTo INDICE:
    Else
        BLANK = 0
    End If
    If INDICENAME = "RANGE" Then GoTo NOMO:
    'DEFINE NEXT COLUMN IN MASTER
    STARTER3 = Asc("G")
    STARTER4 = Asc("A")

    If L = 0 Then
        MCURRCOL = "G"
    Else
        If L < 20 Then
            NEXTCOL = STARTER3 + L
            MCURRCOL = Chr(NEXTCOL)
        Else
            NEXTCOL = STARTER4 + (L - 20)
            MCURRCOL = "A" + Chr(NEXTCOL)
        End If
        
    End If
    
    L = L + 1
    K = K + 1
        
    'COPY/PASTE TEST METHOD: ASSUMED TO ALWAYS BE IN ROW 3

    TSTMETH = Range(CURRCOL + "3")
    PSDVAL = Range(CURRCOL + FNDROW(0, 2))
    TARGVAL = Range(CURRCOL + FNDROW(1, 2))
    UPSPEC = Range(CURRCOL + FNDROW(2, 2))
    LOSPEC = Range(CURRCOL + FNDROW(3, 2))
    AVGVAL = Range(CURRCOL + AVGROW)
    DECI1 = Range(CURRCOL + "2")
    
    Windows(MASTERNAME).Activate
    'IF FIRST TIME THRU PASTE DOWN GENERAL HEADER INFO

    'RESET CALCULATION TO AUTOMATIC
    
    With Application
        .Calculation = xlAutomatic
        .MaxChange = 0.001
    End With
    ActiveWorkbook.PrecisionAsDisplayed = False

    If FIRSTER = 0 Then
        Range("B4") = PCODE
        If NAMEFILE = "L" Then
            Range("B6") = SHEETNAME
        Else
            Range("B6") = JOB
        End If
        Range("A8") = LCTN
        Range("B11") = STANDARD
        FIRSTER = 1
        
        'POPULATE FIRST 6 COLUMNS WITH APPROPRIATE MATRICES
        VA = 0
        DATAROWA = 21
        'COLUMN A
        Do While VA < 200
            DTROWA = DATAROWA
            If JOBNUMR(VA, 1) <> Empty Then
                Range("A" + DTROWA) = JOBNUMR(VA, 1)
            End If
            VA = VA + 1
            DATAROWA = DATAROWA + 1
        Loop
        'COLUMN B
        VB = 0
        DATAROWB = 21
        Do While VB < 200
            DTROWB = DATAROWB
            If DATER(VB, 1) <> Empty Then
                Range("B" + DTROWB) = DATER(VB, 1)
            End If
            VB = VB + 1
            DATAROWB = DATAROWB + 1
        Loop
        'COLUMN C
        VC = 0
        DATAROWC = 21
        Do While VC < 200
            DTROWC = DATAROWC
            If DATIME(VC, 1) <> Empty Then
                 Range("C" + DTROWC) = DATIME(VC, 1)
            End If
            VC = VC + 1
            DATAROWC = DATAROWC + 1
        Loop
        'COLUMN D
        VD = 0
        DATAROWD = 21
        Do While VD < 200
            DTROWD = DATAROWD
            If PACKAGE(VD, 1) <> Empty Then
                Range("D" + DTROWD) = PACKAGE(VD, 1)
            End If
            VD = VD + 1
            DATAROWD = DATAROWD + 1
        Loop
        'COLUMN E
        VE = 0
        DATAROWE = 21
        Do While VE < 200
            DTROWE = DATAROWE
            If LINER(VE, 1) <> Empty Then
                Range("E" + DTROWE) = LINER(VE, 1)
            End If
            VE = VE + 1
            DATAROWE = DATAROWE + 1
        Loop
        'COLUMN F
        VF = 0
        DATAROWF = 21
        Do While VF < 200
            DTROWF = DATAROWF
            If CUSTOMER(VF, 1) <> Empty Then
                Range("F" + DTROWF) = CUSTOMER(VF, 1)
            End If
            VF = VF + 1
            DATAROWF = DATAROWF + 1
        Loop
        'DONE WITH FIRST 6 COLUMNS PASTE DOWN
    End If
    
    'INSERT COLUMN IF > COLUMN G
    If L > 1 Then
        Range("F19").Select
        LASTADD = Selection.End(xlToRight).Address
        LASTCHCK = Left(LASTADD, 3)
        If Right(LASTCHCK, 1) = "$" Then
            LASTCOL = Left(LASTADD, 2)
        Else
            LASTCOL = Left(LASTADD, 3)
        End If
        Columns(LASTCOL + ":" + LASTCOL).Select
        Selection.Insert Shift:=xlToRight
    Else
        LASTCOL = "H"
    End If

    If INDICENAME <> "" Then
        Range(MCURRCOL + "19") = INDICENAME
    End If
    
    If TSTMETH <> "" Then
        'SET FORMAT FOR TEST METHOD CELL TO TEXT
        Range(MCURRCOL + "3").Select
        Selection.NumberFormat = "@"
        Range(MCURRCOL + "3") = TSTMETH
    End If
PSD:
    'COPY/PASTE PSD FOR INDICE
    If PSDVAL <> "" Then
        Range(MCURRCOL + FNDROW(0, 1)) = PSDVAL
    End If
TARGET:
    'COPY/PASTE TARGET FOR INDICE
    If TARGVAL <> "" Then
        Range(MCURRCOL + FNDROW(1, 1)) = TARGVAL
    End If
SPEC:
    'COPY/PASTE UPPER/LOWER SPEC FOR INDICE
    If IsError(AVGVAL) = True Then
        AVGVAL = 1
    End If
    'IF UPPER SPEC OR AVERAGE IS NOT BLANK THEN TREAT
    'THE COLUMN AS A COLUMN THAT WILL HOLD ACTUAL USABLE DATA
    'AND PASTE DOWN NEEDED EQUATIONS
    If UPSPEC <> "" Or AVGVAL <> "" Then
        Range(MCURRCOL + FNDROW(2, 1)) = UPSPEC
        Range(MCURRCOL + FNDROW(3, 1)) = LOSPEC

    'COPY/PASTE EQUATIONS FOR AVG, STDEV, DATA POINTS
    '   MAX, MIN, AND RANGE FROM COLUMN G
    
        Range("G" + AVGROW).Select
        Selection.Copy
        Range(MCURRCOL + AVGROW).Select
        Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Range("G" + STDEVROW + ":G" + DATAPTSROW).Select
        Selection.Copy
        Range(MCURRCOL + STDEVROW).Select
        Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Range("G" + MAXROW + ":G" + RANGEROW).Select
        Selection.Copy
        Range(MCURRCOL + MAXROW).Select
        Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
    End If

    'COPY DECIMAL FORMAT FROM ROW 2
    If DECI1 <> "" Then
        Range(MCURRCOL + AVGROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + MAXROW + ":" + MCURRCOL + RANGEROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + MINROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + RANGEROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + TARGROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + UPROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + LOROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + "21:" + MCURRCOL + "220").Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + "2") = DECI1
        'COPY OVER DECIMAL FORMAT TO ROW 2 ON MASTER
        Windows(MASTERNAME).Activate
        Range(MCURRCOL + "2") = DECI1
        GoTo ACTDATA:
    End If
    
    'COPY FORMAT FROM UPPERSPEC TO PICK UP DECIMAL FORMAT
    'IF FILE OF ORIGIN IS TXT
    If DECI1 = "" And EXTENSION = ".TXT" Then
        Windows(FILENAME3).Activate
        If IsError(Range(CURRCOL + "15")) = True Then GoTo ACTDATA:
        DECIVAL = Range(CURRCOL + "15")
        DECILN = Len(DECIVAL)
        H = 1
        ENDER = DECILN + 1
        Do While H < ENDER
            DECICH = Mid(DECIVAL, H, 1)
            If DECICH = "." Or H = DECILN Then
                DECIFORM = DECILN - H
                If DECIFORM = 0 Then
                    DECI1 = "0_)"
                End If
                If DECIFORM = 1 Then
                    DECI1 = "0.0_)"
                End If
                If DECIFORM = 2 Then
                    DECI1 = "0.00_)"
                End If
                If DECIFORM = 3 Then
                    DECI1 = "0.000_)"
                End If
                If DECIFORM = 4 Then
                    DECI1 = "0.0000_)"
                End If
                H = DECILN
    
            End If
            H = H + 1
        Loop
        Windows(MASTERNAME).Activate
        Range(MCURRCOL + AVGROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + MAXROW + ":" + MCURRCOL + RANGEROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + MINROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + RANGEROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + TARGROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + UPROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + LOROW).Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + "21:" + MCURRCOL + "220").Select
        Selection.NumberFormat = DECI1
        Range(MCURRCOL + "2") = DECI1
        Windows(FILENAME3).Activate
    End If
        
    If DECI1 = "" And EXTENSION <> ".TXT" Then
        'COPY FORMAT FROM UPPERSPEC TO PICK UP DECIMAL FORMAT
        'IF FILE OF ORIGIN NOT A TXT FILE
        Windows(FILENAME3).Activate
        If Range(CURRCOL + FNDROW(2, 1)) <> "" Then
            DECI1 = Range(CURRCOL + FNDROW(2, 1)).NumberFormat
            Windows(MASTERNAME).Activate
            Range(MCURRCOL + AVGROW).Select
            Selection.NumberFormat = DECI1
            Range(MCURRCOL + MAXROW + ":" + MCURRCOL + RANGEROW).Select
            Selection.NumberFormat = DECI1
            Range(MCURRCOL + TARGROW).Select
            Selection.NumberFormat = DECI1
            Range(MCURRCOL + "21:" + MCURRCOL + "220").Select
            Selection.NumberFormat = DECI1
            Range(MCURRCOL + "2") = DECI1
        End If
    End If
    
ACTDATA:
    'COPY/PASTE ACTUAL DATA
    Windows(FILENAME3).Activate
    'POPULATE ACTUALDATA MATRIX WITH DATA
    V = 0
    DATAROW = 21
    Do While V < 200
        DTROW = DATAROW
        If Range(CURRCOL + DTROW) <> " " Or Range(CURRCOL + DTROW) <> "" Then
        ACTUALDATA(V, 1) = Range(CURRCOL + DTROW)
        End If
        
        V = V + 1
        DATAROW = DATAROW + 1
    Loop
    Windows(MASTERNAME).Activate
    'FILL IN DATA CELLS ON MASTER
    W = 0
    MDATAROW = 21
    Do While W < 200
        MDTROW = MDATAROW
        If ACTUALDATA(W, 1) <> Empty Or Len(ACTUALDATA(W, 1)) <> 0 Then
            Range(MCURRCOL + MDTROW) = ACTUALDATA(W, 1)
        End If
        W = W + 1
        MDATAROW = MDATAROW + 1

    Loop
    If INDICENAME = "COMMENT" Or INDICENAME = "CUSTOMER" Then
        Columns(LASTCOL + ":" + LASTCOL).Select
        Selection.ColumnWidth = 12.98
    Else
    'AUTOFIT COLUMNS
    Range(MCURRCOL + ":" + MCURRCOL).EntireColumn.AutoFit
    
    End If
    
    Windows(FILENAME3).Activate
    GoTo INDICE:

NOMO:
    Windows(MASTERNAME).Activate

    Range("E:E").EntireColumn.AutoFit
    Range("F:F").Select
    Selection.ColumnWidth = 9.14

    'CLOSE QPRO FILE
    Windows(FILENAME3).Activate
    Beep
    Beep
    ActiveWorkbook.Close (False)
    
    'DELETE SETUP AND IMPORT BUTTONS
    Windows(MASTERNAME).Activate
    Range("A1").Select
    ActiveSheet.DrawingObjects("Button 390").Select
    Selection.Delete
    ActiveSheet.DrawingObjects("Button 392").Select
    Selection.Delete
    
    'DELETE TRANSFER PUSH BUTTON
    ActiveSheet.DrawingObjects("Button 391").Select
    Selection.Delete
    
    'DELETE COMMENTS FOR DELETED BUTTONS
    Range("B1:F1").Select
    Selection.ClearComments
    
    'DELETE XTRA 'TECH' COLUMN
    Range("G19").Select
    LASTCHK1 = Selection.End(xlToRight).Address
    LASTCHK = Left(LASTCHK1, 3)
    If Right(LASTCHK, 1) = "$" Then
        LASTCOL = Left(LASTCHK1, 2)
    Else
        LASTCOL = Left(LASTCHK1, 3)
    End If
    If Range(LASTCOL + "19") = "TECH" Then
        Columns(LASTCOL + ":" + LASTCOL).Delete
    End If
    
    'REFORMAT CELLS ABOVE 'TECH'
    Range("G19").Select
    LASTCHK1 = Selection.End(xlToRight).Address
    LASTCHK = Left(LASTCHK1, 3)
    If Right(LASTCHK, 1) = "$" Then
        LST = Left(LASTCHK1, 2)
        LASTCOL = Right(LST, 1)
        MOTIF = Asc(LASTCOL)
        MOTIF = MOTIF - 1
        SECLASTCOL = Chr(MOTIF)
    Else
        LST = Left(LASTCHK1, 3)
        LASTCOL = Right(LST, 2)
        MOTIF = Asc(Right(LASTCOL, 1))
        MOTIF = MOTIF - 1
        SECLASTCOL = "A" + Chr(MOTIF)
    End If
    Range(LASTCOL + "1").Copy
    Range(LASTCOL + "3:" + SECLASTCOL + "17").Select
    With Selection.Interior
        .ColorIndex = 5
        .Pattern = xlSolid
    End With

    'REFORMAT INDICE 'TITLE' ROW
    Range("G19:" + LASTCOL + "19").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 10
    End With
    With Selection.Interior
        .ColorIndex = 3
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With

    'REFORMAT CELLS IN 'SPEC REGION
    Range("G19").Select
    FORMATER = Selection.End(xlToRight).Column
    FORMATER = FORMATER - 1
    FORMATTER = Cells(19, FORMATER).Address
    
    FORMCHK = Left(FORMATTER, 3)
    If Right(FORMCHK, 1) = "$" Then
        LST1 = Left(FORMCHK, 2)
        LASTCOL1 = Right(LST1, 1)
        FRMAT = Asc(LASTCOL1)
        FRMAT = FRMAT - 1
        LASTFORM = Chr(FRMAT)
    Else
        LST1 = Left(FORMCHK, 3)
        LASTCOL1 = Right(LST1, 2)
        FRMAT = Asc(Right(LASTCOL1, 1))
        FRMAT = FRMAT - 1
        LASTFORM = "A" + Chr(FRMAT)
    End If
    Range("G4:" + LASTFORM + "17").Select
    
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 10
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With

    'REFORMAT 'METHOD' CELLS
    Range("G3:" + LASTFORM + "3").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    'CHANGE COLOR OF CALCULATED ROWS
    Range("G5:" + LASTFORM + "5").Select
    With Selection.Interior
        .ColorIndex = 1
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    With Selection.Font
        .ColorIndex = 2
    End With
    Range("G7:" + LASTFORM + "9").Select
    With Selection.Interior
        .ColorIndex = 1
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    With Selection.Font
        .ColorIndex = 2
    End With
    Range("G12:" + LASTFORM + "17").Select
    With Selection.Interior
        .ColorIndex = 1
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    With Selection.Font
        .ColorIndex = 2
    End With

    
    'GET WORKSHEET BACK TO 'ORIGINAL' APPEARANCE
    Range("G1").Select
    Range("A1").Select
    
    'CHECK FOR SPACES IN CELLS
    Call SPACE
    
    'CONVERT ALL JOB NUMBERS FROM TEXT TO NUMBERS
    Call TEXT_JOB
    
    'RUN CALC MACROS TO COMPILE DATA
    If newbe = 0 And COMPILEQ = "YES" Then
        Call EXPERTCOMPILE
    End If
    
    'set view to first line last job
    COMFORT = THRU
    Range("A" + COMFORT).Select
    
    'SAVE FILE
    Call SAVE_FILE

    'END TRANSFERS
    
    Range("A20").Select
    Range("G1").Select
    Range("A1").Select

TERMINATE:
    If VIEWSET = "F" Then
        Application.DisplayFullScreen = True
        ActiveWindow.WindowState = xlMaximized
    Else
        ActiveWindow.WindowState = xlMaximized
    End If

End Sub

mole999 · Dec 9, 2015

with a test copy, what happens when you open in 2013 and then run the macros to import, step by step what issues occur

At a guess I would expect a file save format issue from the code, but 2013 should be able to save as you would expect and then need to look at the out put file for any identifiable issue

buzz71023 · Dec 9, 2015

As soon as you select the file in the directory prompt and select open, an error pops up "this file is not in a recognizable format ... (with three bullet point under it)".. then opens up the "Text Import Wizard"

The first debug I get is on

Code:

Workbooks.Open FileName:=FileName, UpdateLinks:=0

and its an Run-time error 1004
MEthod 'Open' of object 'Workbooks' failed

mole999 · Dec 9, 2015

if I read this right from 2013 you need to do https://msdn.microsoft.com/en-us/library/office/ff834966.aspx

buzz71023 · Dec 10, 2015

I'm still a bit of a rookie when in come to advanced VBA. I knowledge it limited to a lot of the basics. So with that said, I don't see how this applies to converting this WQ1 to xlms and I definitely do not understand how to use it or where it would go.

mole999 · Dec 10, 2015

It looks like that the filename needs to be picked up as the later instructions

convert .wq1 to .xlsm

buzz71023

Active Member

mole999

Well-known Member

buzz71023

Active Member

mole999

Well-known Member

buzz71023

Active Member

mole999

Well-known Member

Similar threads

Share this page

convert .wq1 to .xlsm

buzz71023

Active Member

mole999

Well-known Member

buzz71023

Active Member

mole999

Well-known Member

buzz71023

Active Member

mole999

Well-known Member

Similar threads

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock