Solved

How to insert a module macro into a workbook after a macro runs?

Posted on 2014-10-05
18
109 Views
Last Modified: 2014-10-07
I have a current macro that I want to insert into a workbook AFTER I run another macro that formats the workbook...is this possible?
Example: I open a workbook with data on it. Now I will run a macro to format the data...then at the end it will insert a module macro so a user can run it.
Thanks,
Jimi
0
Comment
Question by:Jimi Sherman
  • 7
  • 6
  • 4
  • +1
18 Comments
 
LVL 26

Expert Comment

by:MacroShadow
ID: 40363000
Yes, it is possible. The exact code depends on whether you're copying the code from an existing module (in a different project), or creating new code and whether you want to create a new module for the macro. All of the above and much more you can find on Chip Pearson's site. Here is a small sample:
Sub CreateProcedure()
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule
    Dim S As String
    Dim LineNum As Long
    
    ' Use the next two lines to create a new module for the code
    'Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule)
    'VBComp.Name = "NewModule"
    ' OR use the following line to use an existing module for the code
    'Set VBComp = ThisWorkbook.VBProject.VBComponents("Module2")    
    
    Set CodeMod = VBComp.CodeModule
    LineNum = CodeMod.CountOfLines + 1
    S = "Sub HelloWorld()" & vbCrLf & _
        "    MsgBox ""Hello, World""" & vbCrLf & _
        "End Sub"
    CodeMod.InsertLines LineNum, S
End Sub

Open in new window


 This code creates the procedure:
    Sub HelloWorld()
        MsgBox "Hello, World"
    End Sub

Open in new window

0
 

Author Comment

by:Jimi Sherman
ID: 40363011
Hi Macroshadow, I don't understand I am kinda of new at this. Where would I put this in my macro?
Sub BH_Format_Master_Eq_Scan()

    Dim cell As Range
    Application.ScreenUpdating = False
'No apartment # move over
        Dim iLstRow As Long
        Dim iRow As Long
        iLstRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
        For iRow = 2 To iLstRow Step 1
            If Cells(iRow, "N").Value = "" Then
                'This is the move part.  It will cut the range from the first to the second and paste in the column set after the .Cut part
                Cells(iRow, "N").Value = Cells(iRow, "M").Value
                Cells(iRow, "M").Value = ""
            End If
        Next iRow
'split up address
    Columns("O:P").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("N:N").Select
    Selection.TextToColumns Destination:=Range("N1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Columns("O:O").Select
'trim state Remove blankspaces
    Dim rng As Range
    For Each rng In Intersect(ActiveSheet.UsedRange.Cells, ActiveSheet.Range("O:O"))
    rng.Value = Application.WorksheetFunction.Trim(rng.Value)
    Next
    Selection.TextToColumns Destination:=Range("O1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Columns("P:P").Select
    Selection.Delete Shift:=xlToLeft
    Range("O1").Select
    ActiveCell.FormulaR1C1 = "State"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Acct"
    Range("A2").Select
    
    Application.ScreenUpdating = True
End Sub

Open in new window

0
 
LVL 33

Expert Comment

by:Norie
ID: 40363015
Couldn't you use a template workbook with the code already in it?
0
 

Author Comment

by:Jimi Sherman
ID: 40363018
I don't think that will work due to I am taken 3 workbooks and merging them into 1. Then I am run my macro on that Merged workbook to format it.
0
 
LVL 33

Expert Comment

by:Norie
ID: 40363020
What wouldn't work?

Also, why do you need this code in the workbook you are creating by merging the other workbooks?
0
 

Author Comment

by:Jimi Sherman
ID: 40363037
When I merge the 3 files into one that would make a NEW workbook. I not sure how I would get that into a template?
The macro I want to insert is for is for a user. This file will be sent out daily I don't want to copy and paste the USER macro all the time.
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 40363042
Is the code you posted, the code to write to the module? (if not please post it).
0
 
LVL 33

Expert Comment

by:Norie
ID: 40363044
Where in your code are you creating the new workbook?
0
 

Author Comment

by:Jimi Sherman
ID: 40363056
The code I posted earlier is the FORMATTING part after I merge the 3 files.
At the end of that code I would like to insert this code as a module.

Sub BH_Enter_SerialNumber_ORLANDO()
    Dim sWorkbookName As String
    Dim sWorkbookName2 As String
    Dim sWorkbookNamePath As String
    Dim sWorkbookNamePath2 As String
    Dim sScanSerial As String
    Dim fCell, dCell, lCell, eCell, cCell, nCell, oCell, pCell As String
    Dim sAcct, sAddress, sBillCode As String
    Dim sMarket As String
    Dim sTechID As String
    Dim sOffice As String
    Dim sWorkID As String
    Dim iRow As Long
    Dim iRet As Integer

    sMarket = "CFL" 'CFL or TPA
    sTechID = "1234" 'Office managers #
    sOffice = "Orlando"
    
    On Error Resume Next
    sWorkbookName = ThisWorkbook.Name
    Windows(sWorkbookName).Activate
    sWorkbookNamePath = ActiveWorkbook.FullName
    sWorkbookName2 = IsWbOpen(sOffice & "-LABS_Returned_EQ")
    If sWorkbookName2 = "" Then
        iRet = MsgBox("Start a New Equipment Scan spreadsheet?", vbYesNo, "Box Serial Lookup")
        If iRet = 7 Then
            ChDrive Left(sWorkbookNamePath, 3)
            ChDir Left(sWorkbookNamePath, InStrRev(sWorkbookNamePath, "\"))
            filetoopen = Application.GetOpenFilename(Title:="Please choose a Return file to add to", FileFilter:=sOffice & "-LABS_Returned_EQ (*.xlsx),")
            If filetoopen = False Then
                Beep
                MsgBox "No file specified.", vbExclamation, "Error!"
                Exit Sub
            Else
                sWorkbookNamePath2 = filetoopen
                Workbooks.Open (sWorkbookNamePath2)
            End If
        Else
            sWorkbookNamePath2 = Left(sWorkbookNamePath, InStrRev(sWorkbookNamePath, "\")) & sOffice & "-LABS_Returned_EQ_" & Format(Date, "yyyy-mm-dd") & ".xlsx"
            If FileOrDirExists(sWorkbookNamePath2) Then
                Workbooks.Open (sWorkbookNamePath2)
            Else
                Workbooks.Add
                Range("A1").Select
                ActiveCell.FormulaR1C1 = "Work Order ID"
                Range("B1").Select
                ActiveCell.FormulaR1C1 = "Contractor Abb"
                Range("C1").Select
                ActiveCell.FormulaR1C1 = "Market Abb"
                Range("D1").Select
                ActiveCell.FormulaR1C1 = "WA Tech ID"
                Range("E1").Select
                ActiveCell.FormulaR1C1 = "WO Close Date"
                Range("F1").Select
                ActiveCell.FormulaR1C1 = "Flag Reporting"
                Range("G1").Select
                ActiveCell.FormulaR1C1 = "LOB"
                Range("H1").Select
                ActiveCell.FormulaR1C1 = "TASK Code"
                Range("I1").Select
                ActiveCell.FormulaR1C1 = "Task Code Quanity"
                Range("J1").Select
                ActiveCell.FormulaR1C1 = "Start Date"
                Range("K1").Select
                ActiveCell.FormulaR1C1 = "End Date"
                Range("L1").Select
                ActiveCell.FormulaR1C1 = "Arrival Time"
                Range("M1").Select
                ActiveCell.FormulaR1C1 = "Job Notes (Serials)"
                Range("N1").Select
                ActiveCell.FormulaR1C1 = "Acc #"
                Range("O1").Select
                ActiveCell.FormulaR1C1 = "Address"
                Range("P1").Select
                ActiveCell.FormulaR1C1 = "City"
                Range("Q1").Select
                ActiveCell.FormulaR1C1 = "State"
                Range("R1").Select
                ActiveCell.FormulaR1C1 = "ZIP"
                Range("S1").Select
                ActiveCell.FormulaR1C1 = "Amount Owed"
                Range("T1").Select
                ActiveCell.FormulaR1C1 = "Amount Collected"
                Range("U1").Select
                ActiveCell.FormulaR1C1 = "Market Area Abb"
                Range("A2").Select
            'format
                Columns("A:A").Select
                Selection.NumberFormat = "@"
                Columns("E:E").Select
                Selection.NumberFormat = "mm/dd/yyyy"
                Columns("J:K").Select
                Selection.NumberFormat = "mm/dd/yyyy"
                Columns("M:M").Select
                Selection.NumberFormat = "@"
                Rows("1:1").Select
                Selection.Font.Bold = True
                Cells.Select
                With Selection
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                End With
                Columns("M:R").Select
                With Selection
                    .HorizontalAlignment = xlLeft
                    .VerticalAlignment = xlCenter
                End With
                Range("A2").Select
                ActiveWindow.FreezePanes = True
                
                ActiveWorkbook.SaveAs Filename:=sWorkbookNamePath2, _
                    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            End If
        End If
        sWorkbookName2 = ActiveWorkbook.Name
    Else
        sWorkbookNamePath2 = Left(sWorkbookNamePath, InStrRev(sWorkbookNamePath, "\")) & sWorkbookName2
    End If
    Windows(sWorkbookName).Activate
    Sheets("Merge Files").Select
'========================================================================================================
'Scan process
    Windows(sWorkbookName2).Activate
    iRow = Cells(Rows.Count, "B").End(xlUp).Row + 1
    Range("A" & iRow).Select
Reenter:
    sScanSerial = InputBox("Scan or type equipment serial number", "Serial Number Processor")
    sScanSerial = Replace(sScanSerial, "*", "")
    If Len(Trim(sScanSerial)) < 5 And Len(Trim(sScanSerial)) > 0 Then
        Beep
        MsgBox "Serial numbers need to be at least 5 characters.", vbOKOnly, "Illegal entry error"
        GoTo Reenter
    End If
    While sScanSerial > ""
        Windows(sWorkbookName).Activate
        cCell = "C" 'Mt Area
        dCell = "D" 'Acct number from list
        eCell = "E" 'Billing Code
        lCell = "L" 'ADDRESS from list
        nCell = "N" 'City
        oCell = "O" 'State
        pCell = "P" 'Zip
        fCell = "M1" 'Serial Number added to log
        Range(fCell).Select
        Cells.Find(What:=sScanSerial, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
            SearchFormat:=False).Activate
        If ActiveCell.Address <> "$M$1" Then
            Range(cCell & Mid(ActiveCell.Address, 4, 8)).Select
            sMtArea = ActiveCell.FormulaR1C1
            Range(dCell & Mid(ActiveCell.Address, 4, 8)).Select
            sAcct = ActiveCell.FormulaR1C1
                sWorkID = sAcct & Format(Now(), "mmddyyyy")
            Range(eCell & Mid(ActiveCell.Address, 4, 8)).Select
            sBillCode = ActiveCell.FormulaR1C1
            Range(lCell & Mid(ActiveCell.Address, 4, 8)).Select
            sAddress = ActiveCell.FormulaR1C1
            Range(nCell & Mid(ActiveCell.Address, 4, 8)).Select
            sCity = ActiveCell.FormulaR1C1
            Range(oCell & Mid(ActiveCell.Address, 4, 8)).Select
            sState = ActiveCell.FormulaR1C1
            Range(pCell & Mid(ActiveCell.Address, 4, 8)).Select
            sZip = ActiveCell.FormulaR1C1
            
            Windows(sWorkbookName2).Activate
            Range("A" & iRow).Select
            ActiveCell.FormulaR1C1 = sWorkID
            Range("B" & iRow).Select
            ActiveCell.FormulaR1C1 = "LABS"
            Range("C" & iRow).Select
            ActiveCell.FormulaR1C1 = sMarket
            Range("D" & iRow).Select
            ActiveCell.FormulaR1C1 = sTechID
            Range("E" & iRow).Select
            ActiveCell.FormulaR1C1 = Date
            Range("F" & iRow).Select
            ActiveCell.FormulaR1C1 = "Y"
            Range("G" & iRow).Select
            ActiveCell.FormulaR1C1 = "COL"
            Range("H" & iRow).Select
            ActiveCell.FormulaR1C1 = sBillCode
            Range("I" & iRow).Select
            ActiveCell.FormulaR1C1 = "1"
            Range("J" & iRow).Select
            ActiveCell.FormulaR1C1 = Date
            Range("K" & iRow).Select
            ActiveCell.FormulaR1C1 = Date
            Range("M" & iRow).Select
            ActiveCell.FormulaR1C1 = sScanSerial
            Range("N" & iRow).Select
            ActiveCell.FormulaR1C1 = sAcct
            Range("O" & iRow).Select
            ActiveCell.FormulaR1C1 = sAddress
            Range("P" & iRow).Select
            ActiveCell.FormulaR1C1 = sCity
            Range("Q" & iRow).Select
            ActiveCell.FormulaR1C1 = sState
            Range("R" & iRow).Select
            ActiveCell.FormulaR1C1 = sZip
            Range("U" & iRow).Select
            ActiveCell.FormulaR1C1 = sMtArea
        Else
            ' If serial number was not found input Found Box"
            Beep
            Windows(sWorkbookName2).Activate
            Range("B" & iRow).Select
            ActiveCell.FormulaR1C1 = "LABS"
            Range("C" & iRow).Select
            ActiveCell.FormulaR1C1 = sMarket
            Range("D" & iRow).Select
            ActiveCell.FormulaR1C1 = sTechID
            Range("E" & iRow).Select
            ActiveCell.FormulaR1C1 = Date
            Range("F" & iRow).Select
            ActiveCell.FormulaR1C1 = "Y"
            Range("G" & iRow).Select
            ActiveCell.FormulaR1C1 = "COL"
            Range("J" & iRow).Select
            ActiveCell.FormulaR1C1 = Date
            Range("K" & iRow).Select
            ActiveCell.FormulaR1C1 = Date
            Range("M" & iRow).Select
            ActiveCell.FormulaR1C1 = sScanSerial
            Range("N" & iRow).Select
            ActiveCell.FormulaR1C1 = "Found Box"
        End If
        'ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
        'ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("N1:N1"), _
        '    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        'With ActiveWorkbook.Worksheets("Sheet1").Sort
        '    .SetRange Range("A:U")
        '    .Header = xlYes
        '    .MatchCase = False
        '    .Orientation = xlTopToBottom
        '    .SortMethod = xlPinYin
        '    .Apply
        'End With
        Columns("A:U").Select
        Columns("A:U").EntireColumn.AutoFit
        Range("A" & iRow & ":U" & iRow).Select
        iRow = iRow + 1
ReenterB:
        sScanSerial = InputBox("Scan or type equipment serial number", "Serial Number Processor")
        If StrPtr(sScanSerial) = 0 Then
            Windows(sWorkbookName2).Activate
        Else
            sScanSerial = Replace(sScanSerial, "*", "")
            If Len(Trim(sScanSerial)) < 5 And Len(Trim(sScanSerial)) > 0 Then
                Beep
                MsgBox "Serial numbers need to be at least 5 characters.", vbOKOnly, "Illegal entry error"
                GoTo ReenterB
            End If
        End If
    Wend
End Sub
Function FileOrDirExists(PathName As String) As Boolean
    Dim iTemp As Integer
    On Error Resume Next
    iTemp = GetAttr(PathName)
    Select Case Err.Number
        Case Is = 0
            FileOrDirExists = True
        Case Else
            FileOrDirExists = False
    End Select
    On Error GoTo 0
End Function
Function IsWbOpen(wbName As String) As String
    Dim i As Long
    IsWbOpen = ""
    For i = Workbooks.Count To 1 Step -1
        If InStr(1, Workbooks(i).Name, wbName) > 0 Then
            IsWbOpen = Workbooks(i).Name
            Exit For
        End If
    Next
End Function

Open in new window

0
What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
LVL 33

Expert Comment

by:Norie
ID: 40363072
So this is where you create the new workbook?
Workbooks.Add

Open in new window

If it is then you can easily change that line of code to create a new workbook from a template that already has the code in it.

All you need to do is use the. Template argument of the Add method.

For example.
Workbooks.Add Template:="C:\PathToTemplate\NameOfTheTemplateWorkbookThatAlreadyHasTheCodeInIt.xlsm"

Open in new window

0
 

Author Comment

by:Jimi Sherman
ID: 40363102
OK added this at the end and the results was...it just opened the template...it did not add it to the new workbook that I already had opened.
Workbooks.Add Template:="C:\Users\Jimi\AppData\Roaming\Microsoft\Templates\BrightHouse_Item_Code_Reference.xltm"

Open in new window

0
 
LVL 33

Expert Comment

by:Norie
ID: 40363120
What new workbook are you talking about?

Are you manually creating a new workbook?
0
 

Author Comment

by:Jimi Sherman
ID: 40363126
Yes
I am taking 3 files that are emailed to me...I save these. Now I make 1 NEW workbook from all 3 files...merged workbook.
With this workbook open I am running the FORMATTING macro on it.
0
 
LVL 33

Expert Comment

by:Norie
ID: 40363137
Sorry, you've lost me.

What code so you want to run on this newly created workbook, what code do you want to add to it, and why do you want to add that code to the new workbook?
0
 
LVL 26

Accepted Solution

by:
MacroShadow earned 500 total points
ID: 40363806
Try this code:
Sub BH_Format_Master_Eq_Scan()

    Dim cell As Range
    Dim iLstRow As Long
    Dim iRow As Long
    Dim rng As Range

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule
    Dim S As String
    Dim LineNum As Long

    ' Use the next two lines to create a new module for the code
    Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule)
    VBComp.Name = "NewModule"
    ' OR use the following line to use an existing module for the code
    'Set VBComp = ThisWorkbook.VBProject.VBComponents("Module2")

    Set CodeMod = VBComp.CodeModule
    LineNum = CodeMod.CountOfLines + 1
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    Application.ScreenUpdating = False
    'No apartment # move over
    iLstRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    For iRow = 2 To iLstRow Step 1
        If Cells(iRow, "N").Value = "" Then
            'This is the move part.  It will cut the range from the first to the second and paste in the column set after the .Cut part
            Cells(iRow, "N").Value = Cells(iRow, "M").Value
            Cells(iRow, "M").Value = ""
        End If
    Next iRow
    'split up address
    Columns("O:P").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("N:N").Select
    Selection.TextToColumns Destination:=Range("N1"), DataType:=xlDelimited, _
                            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                            Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
                                                                                       :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Columns("O:O").Select
    'trim state Remove blankspaces
    For Each rng In Intersect(ActiveSheet.UsedRange.Cells, ActiveSheet.Range("O:O"))
        rng.Value = Application.WorksheetFunction.Trim(rng.Value)
    Next
    Selection.TextToColumns Destination:=Range("O1"), DataType:=xlDelimited, _
                            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
                            Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
                                                                                       :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Columns("P:P").Select
    Selection.Delete Shift:=xlToLeft
    Range("O1").Select
    ActiveCell.FormulaR1C1 = "State"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Acct"
    Range("A2").Select

    Application.ScreenUpdating = True
     
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Use the next two lines to create a new module for the code
    Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule)
    VBComp.Name = "NewModule"
    ' OR use the following line to use an existing module for the code
    'Set VBComp = ThisWorkbook.VBProject.VBComponents("Module2")

    Set CodeMod = VBComp.CodeModule
    LineNum = CodeMod.CountOfLines + 1

    S = "Sub BH_Enter_SerialNumber_ORLANDO()" & vbCrLf & vbCrLf

    S = S & "    Dim sWorkbookName As String" & vbCrLf
    S = S & "    Dim sWorkbookName2 As String" & vbCrLf
    S = S & "    Dim sWorkbookNamePath As String" & vbCrLf
    S = S & "    Dim sWorkbookNamePath2 As String" & vbCrLf
    S = S & "    Dim sScanSerial As String" & vbCrLf
    S = S & "    Dim fCell As String, dCell As String, lCell As String, eCell As String, cCell As String, nCell As String, oCell As String, pCell As String" & vbCrLf
    S = S & "    Dim sAcct As String, sAddress As String, sBillCode As String" & vbCrLf
    S = S & "    Dim sMarket As String" & vbCrLf
    S = S & "    Dim sTechID As String" & vbCrLf
    S = S & "    Dim sOffice As String" & vbCrLf
    S = S & "    Dim sWorkID As String" & vbCrLf
    S = S & "    Dim iRow As Long" & vbCrLf
    S = S & "    Dim iRet As Integer" & vbCrLf & vbCrLf

    S = S & "    sMarket = ""CFL""    'CFL or TPA" & vbCrLf
    S = S & "    sTechID = ""1234""    'Office managers #" & vbCrLf
    S = S & "    sOffice = ""Orlando""" & vbCrLf & vbCrLf

    S = S & "    On Error Resume Next" & vbCrLf
    S = S & "    sWorkbookName = ThisWorkbook.Name" & vbCrLf
    S = S & "    Windows(sWorkbookName).Activate" & vbCrLf
    S = S & "    sWorkbookNamePath = ActiveWorkbook.FullName" & vbCrLf
    S = S & "    sWorkbookName2 = IsWbOpen(sOffice & ""-LABS_Returned_EQ"")" & vbCrLf & vbCrLf

    S = S & "    If sWorkbookName2 = """" Then" & vbCrLf
    S = S & "        iRet = MsgBox(""Start a New Equipment Scan spreadsheet?"", vbYesNo, ""Box Serial Lookup"")" & vbCrLf
    S = S & "        If iRet = 7 Then" & vbCrLf
    S = S & "            ChDrive Left(sWorkbookNamePath, 3)" & vbCrLf
    S = S & "            ChDir Left(sWorkbookNamePath, InStrRev(sWorkbookNamePath, ""\""))" & vbCrLf
    S = S & "            filetoopen = Application.GetOpenFilename(title:=""Please choose a Return file to add to"", FileFilter:=sOffice & ""-LABS_Returned_EQ (*.xlsx),"")" & vbCrLf
    S = S & "            If filetoopen = False Then" & vbCrLf
    S = S & "                Beep" & vbCrLf
    S = S & "                MsgBox ""No file specified."", vbExclamation, ""Error!""" & vbCrLf
    S = S & "                Exit Sub" & vbCrLf
    S = S & "            Else" & vbCrLf
    S = S & "                sWorkbookNamePath2 = filetoopen" & vbCrLf
    S = S & "                Workbooks.Open (sWorkbookNamePath2)" & vbCrLf
    S = S & "           End If" & vbCrLf
    S = S & "       Else" & vbCrLf
    S = S & "           sWorkbookNamePath2 = Left(sWorkbookNamePath, InStrRev(sWorkbookNamePath, ""\"")) & sOffice & ""-LABS_Returned_EQ_"" & Format(Date, ""yyyy-mm-dd"") & "".xlsx" & vbCrLf
    S = S & "           If FileOrDirExists(sWorkbookNamePath2) Then" & vbCrLf
    S = S & "               Workbooks.Open (sWorkbookNamePath2)" & vbCrLf
    S = S & "           Else" & vbCrLf
    S = S & "               Workbooks.Add" & vbCrLf
    S = S & "               Range(""A1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Work Order ID""" & vbCrLf
    S = S & "               Range(""B1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Contractor Abb""" & vbCrLf
    S = S & "               Range(""C1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Market Abb""" & vbCrLf
    S = S & "               Range(""D1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""WA Tech ID""" & vbCrLf
    S = S & "               Range(""E1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""WO Close Date""" & vbCrLf
    S = S & "               Range(""F1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Flag Reporting""" & vbCrLf
    S = S & "               Range(""G1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""LOB" & vbCrLf
    S = S & "               Range(""H1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""TASK Code""" & vbCrLf
    S = S & "               Range(""I1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Task Code Quanity""" & vbCrLf
    S = S & "               Range(""J1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Start Date" & vbCrLf
    S = S & "               Range(""K1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""End Date""" & vbCrLf
    S = S & "               Range(""L1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Arrival Time""" & vbCrLf
    S = S & "               Range(""M1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Job Notes (Serials)""" & vbCrLf
    S = S & "               Range(""N1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Acc #""" & vbCrLf
    S = S & "               Range(""O1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Address""" & vbCrLf
    S = S & "               Range(""P1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""City""" & vbCrLf
    S = S & "               Range(""Q1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""State""" & vbCrLf
    S = S & "               Range(""R1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""ZIP""" & vbCrLf
    S = S & "               Range(""S1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Amount Owed""" & vbCrLf
    S = S & "               Range(""T1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Amount Collected""" & vbCrLf
    S = S & "               Range(""U1"").Select" & vbCrLf
    S = S & "               ActiveCell.FormulaR1C1 = ""Market Area Abb""" & vbCrLf
    S = S & "               Range(""A2"").Select" & vbCrLf
    S = S & "               'format" & vbCrLf
    S = S & "               Columns(""A:A"").Select" & vbCrLf
    S = S & "               Selection.NumberFormat = ""@""" & vbCrLf
    S = S & "               Columns(""E:E"").Select" & vbCrLf
    S = S & "               Selection.NumberFormat = ""mm/dd/yyyy""" & vbCrLf
    S = S & "               Columns(""J:K"").Select" & vbCrLf
    S = S & "               Selection.NumberFormat = ""mm/dd/yyyy""" & vbCrLf
    S = S & "               Columns(""M:M"").Select" & vbCrLf
    S = S & "               Selection.NumberFormat = ""@""" & vbCrLf
    S = S & "               Rows(""1:1"").Select" & vbCrLf
    S = S & "               Selection.Font.Bold = True" & vbCrLf
    S = S & "               Cells.Select" & vbCrLf
    S = S & "               With Selection" & vbCrLf
    S = S & "                   .HorizontalAlignment = xlCenter" & vbCrLf
    S = S & "                   .VerticalAlignment = xlCenter" & vbCrLf
    S = S & "               End With" & vbCrLf
    S = S & "               Columns(""M:R"").Select" & vbCrLf
    S = S & "               With Selection" & vbCrLf
    S = S & "                   .HorizontalAlignment = xlLeft" & vbCrLf
    S = S & "                   .VerticalAlignment = xlCenter" & vbCrLf
    S = S & "               End With" & vbCrLf
    S = S & "               Range(""A2"").Select" & vbCrLf
    S = S & "               ActiveWindow.FreezePanes = True" & vbCrLf
    S = S & "               ActiveWorkbook.SaveAs fileName:=sWorkbookNamePath2, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False" & vbCrLf
    S = S & "           End If" & vbCrLf
    S = S & "        End If" & vbCrLf
    S = S & "        sWorkbookName2 = ActiveWorkbook.Name" & vbCrLf
    S = S & "    Else" & vbCrLf
    S = S & "        sWorkbookNamePath2 = Left(sWorkbookNamePath, InStrRev(sWorkbookNamePath, ""\"")) & sWorkbookName2" & vbCrLf
    S = S & "    End If" & vbCrLf

    S = S & "    Windows(sWorkbookName).Activate" & vbCrLf
    S = S & "    Sheets(""Merge Files"").Select" & vbCrLf
    S = S & "    '========================================================================================================" & vbCrLf
    S = S & "    'Scan process" & vbCrLf
    S = S & "    Windows(sWorkbookName2).Activate" & vbCrLf
    S = S & "    iRow = Cells(Rows.Count, ""B"").End(xlUp).Row + 1" & vbCrLf
    S = S & "    Range(""A"" & iRow).Select" & vbCrLf
    S = S & "Reenter:" & vbCrLf
    S = S & "    sScanSerial = InputBox(""Scan or type equipment serial number"", ""Serial Number Processor"")" & vbCrLf
    S = S & "    sScanSerial = Replace(sScanSerial, ""*"", """")" & vbCrLf
    S = S & "    If Len(Trim(sScanSerial)) < 5 And Len(Trim(sScanSerial)) > 0 Then" & vbCrLf
    S = S & "        Beep" & vbCrLf
    S = S & "        MsgBox ""Serial numbers need to be at least 5 characters."", vbOKOnly, ""Illegal entry error""" & vbCrLf
    S = S & "        GoTo Reenter" & vbCrLf
    S = S & "    End If" & vbCrLf
    S = S & "    While sScanSerial > """ & vbCrLf
    S = S & "        Windows(sWorkbookName).Activate" & vbCrLf
    S = S & "        cCell = ""C""    'Mt Area" & vbCrLf
    S = S & "        dCell = ""D""    'Acct number from list" & vbCrLf
    S = S & "        eCell = ""E""    'Billing Code" & vbCrLf
    S = S & "        lCell = ""L""    'ADDRESS from list" & vbCrLf
    S = S & "        nCell = ""N""    'City" & vbCrLf
    S = S & "        oCell = ""O""    'State" & vbCrLf
    S = S & "        pCell = ""P""    'Zip" & vbCrLf
    S = S & "        fCell = ""M1""   'Serial Number added to log" & vbCrLf
    S = S & "        Range(fCell).Select" & vbCrLf
    S = S & "        Cells.Find(What:=sScanSerial, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate" & vbCrLf
    S = S & "        If ActiveCell.Address <> ""$M$1"" Then" & vbCrLf
    S = S & "            Range(cCell & Mid(ActiveCell.Address, 4, 8)).Select" & vbCrLf
    S = S & "            sMtArea = ActiveCell.FormulaR1C1" & vbCrLf
    S = S & "            Range(dCell & Mid(ActiveCell.Address, 4, 8)).Select" & vbCrLf
    S = S & "            sAcct = ActiveCell.FormulaR1C1" & vbCrLf
    S = S & "            sWorkID = sAcct & Format(Now(), ""mmddyyyy"")" & vbCrLf
    S = S & "            Range(eCell & Mid(ActiveCell.Address, 4, 8)).Select" & vbCrLf
    S = S & "            sBillCode = ActiveCell.FormulaR1C1" & vbCrLf
    S = S & "            Range(lCell & Mid(ActiveCell.Address, 4, 8)).Select" & vbCrLf
    S = S & "            sAddress = ActiveCell.FormulaR1C1" & vbCrLf
    S = S & "            Range(nCell & Mid(ActiveCell.Address, 4, 8)).Select" & vbCrLf
    S = S & "            sCity = ActiveCell.FormulaR1C1" & vbCrLf
    S = S & "            Range(oCell & Mid(ActiveCell.Address, 4, 8)).Select" & vbCrLf
    S = S & "            sState = ActiveCell.FormulaR1C1" & vbCrLf
    S = S & "            Range(pCell & Mid(ActiveCell.Address, 4, 8)).Select" & vbCrLf
    S = S & "            sZip = ActiveCell.FormulaR1C1" & vbCrLf

    S = S & "            Windows(sWorkbookName2).Activate" & vbCrLf
    S = S & "            Range(""A"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sWorkID" & vbCrLf
    S = S & "            Range(""B"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = ""LABS""" & vbCrLf
    S = S & "            Range(""C"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sMarket" & vbCrLf
    S = S & "            Range(""D"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sTechID" & vbCrLf
    S = S & "            Range(""E"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = Date" & vbCrLf
    S = S & "            Range(""F"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = ""Y""" & vbCrLf
    S = S & "            Range(""G"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = ""COL""" & vbCrLf
    S = S & "            Range(""H"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sBillCode" & vbCrLf
    S = S & "            Range(""I"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = ""1""" & vbCrLf
    S = S & "            Range(""J"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = Date" & vbCrLf
    S = S & "            Range(""K"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = Date" & vbCrLf
    S = S & "            Range(""M"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sScanSerial" & vbCrLf
    S = S & "            Range(""N"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sAcct" & vbCrLf
    S = S & "            Range(""O"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sAddress" & vbCrLf
    S = S & "            Range(""P"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sCity" & vbCrLf
    S = S & "            Range(""Q"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sState" & vbCrLf
    S = S & "            Range(""R"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sZip" & vbCrLf
    S = S & "            Range(""U"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sMtArea" & vbCrLf
    S = S & "        Else" & vbCrLf
    S = S & "            ' If serial number was not found input Found Box" & vbCrLf
    S = S & "            Beep" & vbCrLf
    S = S & "            Windows(sWorkbookName2).Activate" & vbCrLf
    S = S & "            Range(""B"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = ""LABS""" & vbCrLf
    S = S & "            Range(""C"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sMarket" & vbCrLf
    S = S & "            Range(""D"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sTechID" & vbCrLf
    S = S & "            Range(""E"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = Date" & vbCrLf
    S = S & "            Range(""F"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = ""Y""" & vbCrLf
    S = S & "            Range(""G"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = ""COL""" & vbCrLf
    S = S & "            Range(""J"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = Date" & vbCrLf
    S = S & "            Range(""K"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = Date" & vbCrLf
    S = S & "            Range(""M"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = sScanSerial" & vbCrLf
    S = S & "            Range(""N"" & iRow).Select" & vbCrLf
    S = S & "            ActiveCell.FormulaR1C1 = ""Found Box""" & vbCrLf
    S = S & "        End If" & vbCrLf
    S = S & "        'ActiveWorkbook.Worksheets(""Sheet1"").Sort.SortFields.Clear" & vbCrLf
    S = S & "        'ActiveWorkbook.Worksheets(""Sheet1"").Sort.SortFields.Add Key:=Range(""N1:N1""), _" & vbCrLf
    S = S & "        '    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal" & vbCrLf
    S = S & "        'With ActiveWorkbook.Worksheets(""Sheet1"").Sort" & vbCrLf
    S = S & "        '    .SetRange Range(""A:U"")" & vbCrLf
    S = S & "        '    .Header = xlYes" & vbCrLf
    S = S & "        '    .MatchCase = False" & vbCrLf
    S = S & "        '    .Orientation = xlTopToBottom" & vbCrLf
    S = S & "        '    .SortMethod = xlPinYin" & vbCrLf
    S = S & "        '    .Apply" & vbCrLf
    S = S & "        'End With" & vbCrLf
    S = S & "          Columns(""A:U"").Select" & vbCrLf
    S = S & "          Columns(""A:U"").EntireColumn.AutoFit" & vbCrLf
    S = S & "          Range(""A"" & iRow & "":U"" & iRow).Select" & vbCrLf
    S = S & "           iRow = iRow + 1" & vbCrLf
    S = S & "ReenterB:" & vbCrLf
    S = S & "          sScanSerial = InputBox(""Scan or type equipment serial number"", ""Serial Number Processor"")" & vbCrLf
    S = S & "    If StrPtr(sScanSerial) = 0 Then" & vbCrLf
    S = S & "        Windows(sWorkbookName2).Activate" & vbCrLf
    S = S & "    Else" & vbCrLf
    S = S & "        sScanSerial = Replace(sScanSerial, ""*"", """")" & vbCrLf
    S = S & "        If Len(Trim(sScanSerial)) < 5 And Len(Trim(sScanSerial)) > 0 Then" & vbCrLf
    S = S & "            Beep" & vbCrLf
    S = S & "            MsgBox ""Serial numbers need to be at least 5 characters."", vbOKOnly, ""Illegal entry error""" & vbCrLf
    S = S & "            GoTo ReenterB" & vbCrLf
    S = S & "        End If" & vbCrLf
    S = S & "    End If" & vbCrLf
    S = S & "    Wend" & vbCrLf & vbCrLf

    S = S & "End Sub" & vbCrLf
    S = S & "Function FileOrDirExists(PathName As String) As Boolean" & vbCrLf
    S = S & "    Dim iTemp As Integer" & vbCrLf
    S = S & "    On Error Resume Next" & vbCrLf
    S = S & "    iTemp = GetAttr(PathName)" & vbCrLf
    S = S & "    Select Case Err.Number" & vbCrLf
    S = S & "        Case Is = 0" & vbCrLf
    S = S & "            FileOrDirExists = True" & vbCrLf
    S = S & "        Case Else" & vbCrLf
    S = S & "            FileOrDirExists = False" & vbCrLf
    S = S & "    End Select" & vbCrLf
    S = S & "    On Error GoTo 0" & vbCrLf
    S = S & "End Function" & vbCrLf
    S = S & "Function IsWbOpen(wbName As String) As String" & vbCrLf
    S = S & "    Dim i As Long" & vbCrLf
    S = S & "    IsWbOpen = """"" & vbCrLf
    S = S & "    For i = Workbooks.Count To 1 Step -1" & vbCrLf
    S = S & "        If InStr(1, Workbooks(i).Name, wbName) > 0 Then" & vbCrLf
    S = S & "            IsWbOpen = Workbooks(i).Name" & vbCrLf
    S = S & "            Exit For" & vbCrLf
    S = S & "        End If" & vbCrLf
    S = S & "    Next" & vbCrLf
    S = S & "End Function"

    CodeMod.InsertLines LineNum, S
    MsgBox "Now you can run BH_Enter_SerialNumber_ORLANDO"
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
End Function

Open in new window

0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 40363823
For the above code to work you must add a reference (from within the Visual Basic Editor) Tools>References: Microsoft Visual Basic for Applications Extensibility 5.3 library
0
 

Author Closing Comment

by:Jimi Sherman
ID: 40364987
Thanks
0
 
LVL 11

Expert Comment

by:jkpieterse
ID: 40365413
How do you make this new workbook, do you use a macro? If so, can you post that macro please?
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now