Excel to internal application

P

pure vito

Board Regular
Joined
Oct 7, 2021
Messages
180
Office Version
  1. 365
Platform
  1. Windows
Hi All,

I'm Trying my best to make this VBA code perform in a way that was not intended when written, Admittedly I'm a novice here,

I'll post the code below I'm sure it's only the Worksheet_SelectionChange Sub that needs addressing I'm just missing something,

I simply would like it to copy the text form B5 and then paste into the application, I really don't expect a solution here as the it won't be visible to you but you may see something I don't,

This code would normally perform the task of copying the information from the application and then post it into the work book, I just want to be able to click a cell and have the number appear in the application,

Appreciate any help given again I'm just throwing this one to the wind I don't expect a solution 😅

VBA Code: 
'Constants
Const CO_HepFileName = "SYA2_Mainframe"
Const CO_DataSheet = "Data 3"
Const CO_Status = "Update Status"
Const CO_Message = "Update Message"

'Hummingbird application and host objects
Private moHostApp As HostExApplication
Private moHostExp As HostExHost
'Sheet row variables
Private mlDataRow As Long
Private miStatusCol As Long
Private miMessageCol As Long
Private msPartNumber As String
'Data record variables

'Data record variable for checking
Private msStatus As String
Private msMessage As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A2:A3000")) Is Nothing Then
Application.ScreenUpdating = False
    
    Worksheets("Data 3").Range("B5") = Range(Target.Address).Value
     

 If MsgBox("Do you wish to run the Hummingbird script?", vbYesNo) = vbNo Then
    Exit Sub
End If
'Try and connect to the Hummingbird session
If Not ConnectToSession Then
Exit Sub
End If


     
With moHostExp
    For I = 3 To cntr
    msPlant = Worksheets("Data 3").Range("B5")
    moHostExp.CursorRC 2, 71
    moHostExp.RunCmd "Erase-Input"
    moHostExp.PutText msPlant, 2, 71
    moHostExp.RunCmd "Enter"
    WaitForScreen
    
        .RunCmd "Home"
        .Keys "GCMMSGABA"
        .RunCmd "Enter"
        WaitForScreen
        msPartNumber = Worksheets("Data 3").Range("B5")
        .CursorRC 3, 8
        .RunCmd "ERASE-LINE"
        .PutText msPartNumber, 3, 8
        .RunCmd "Enter"
        WaitForScreen
 
 
 Application.ScreenUpdating = True
 Next
 
 End With
 
End If

End Sub

'Writes a message and Status to the data sheet
Private Sub WriteLog(sStatus As String, sMsg As String)

  With Worksheets(CO_DataSheet)
    .Cells(mlDataRow, miStatusCol) = sStatus
    .Cells(mlDataRow, miMessageCol) = sMsg
  End With

End Sub

'Get the message from the bottom of the screen
Private Function ScreenMessage() As String
  
  On Error Resume Next
  ScreenMessage = Trim(moHostExp.TextRC(24, 2, 80))
  
End Function

'Connect to the Hummingbird Host Explorer session
Private Function ConnectToSession() As Boolean
  
  On Error GoTo Error_Handler
  
  Set moHostApp = New HostExApplication
  Set moHostExp = moHostApp.CurrentHost
  If moHostExp Is Nothing Then
    MsgBox "There is no '" & CO_HepFileName & "' Hummingbird session running.", vbCritical
    ConnectToSession = False
  Else
    ConnectToSession = True
  End If

  Exit Function

Error_Handler:
  ConnectToSession = False

End Function

'Disconnect from the Hummingbird Host Explorer session
Private Function DisconnectFromSession()

  On Error Resume Next
  
  Set moHostExp = Nothing
  Set moHostApp = Nothing

End Function

'Wait for the screen to refresh after an action key has been pressed (e.g. "Enter" of "Pf8")
Private Sub WaitForScreen()
  
  'Two loops, just to make sure...
  While moHostExp.Keyboard
  Wend
  
  While moHostExp.Keyboard
  Wend
  
End Sub

'Try to find and set variables pointing to the status and message columns in the data sheet. It creates these columns if they
'do not already exist.
Private Function SetStatusColumns() As Boolean
  Dim iCol As Integer
  
  miStatusCol = 0
  miMessageCol = 0
  
  'Try and find update status and message columns
  With Worksheets(CO_DataSheet)
    iCol = 1
    While .Cells(1, iCol) <> ""
      If .Cells(1, iCol) = CO_Status Then
        miStatusCol = iCol
      End If
      If .Cells(1, iCol) = CO_Message Then
        miMessageCol = iCol
      End If
      iCol = iCol + 1
    Wend
  
    'If an update status column does not exist then add it to the end
    If miStatusCol = 0 Then
      miStatusCol = AddHeading(CO_Status)
    End If
  
    'If an update message column does not exist then add it to the end
    If miMessageCol = 0 Then
      miMessageCol = AddHeading(CO_Message)
    End If
  
  End With
  
End Function

Private Function AddHeading(sHeading As String) As Integer
  Dim iCol As Integer
  
  'Find first non blank column heading
  iCol = 1
  While Worksheets(CO_DataSheet).Cells(1, iCol) <> ""
    iCol = iCol + 1
  Wend

  'Add the heading and set background colour
  Worksheets(CO_DataSheet).Cells(1, iCol) = sHeading
  Worksheets(CO_DataSheet).Cells(1, iCol).Interior.ColorIndex = 15
  
  'Set the borders
  With Worksheets(CO_DataSheet).Cells(1, iCol).Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
  End With
  With Worksheets(CO_DataSheet).Cells(1, iCol).Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
  End With
  With Worksheets(CO_DataSheet).Cells(1, iCol).Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
  End With
  With Worksheets(CO_DataSheet).Cells(1, iCol).Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
  End With

  AddHeading = iCol
  
  
End Function

Private Sub Workbook_Open()
  
  On Error Resume Next
  Application.CommandBars("Hummingbird").Controls(1).OnAction = "ThisWorkBook.RunScript"

End Sub
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
The Code before I butchered it 😅


VBA Code: 
'Constants
Const CO_HepFileName = "SYA2_Mainframe"
Const CO_DataSheet = "Data"
Const CO_Status = "Update Status"
Const CO_Message = "Update Message"

'Hummingbird application and host objects
Private moHostApp As HostExApplication
Private moHostExp As HostExHost
'Sheet row variables
Private mlDataRow As Long
Private miStatusCol As Long
Private miMessageCol As Long
Private msPartNumber As String
'Data record variables

'Data record variable for checking
Private msStatus As String
Private msMessage As String

Sub RunScript()
  
'On Error Resume Next

'Confirm that user wants to run the script
If MsgBox("Do you wish to run the Hummingbird script?", vbYesNo) = vbNo Then
    Exit Sub
End If
'Try and connect to the Hummingbird session
If Not ConnectToSession Then
Exit Sub
End If

'A bit of initialisation
'SetStatusColumns
'mlDataRow = 3
cntr = WorksheetFunction.CountA(Worksheets(CO_DataSheet).Columns(2)) + 1
Worksheets(CO_DataSheet).Range("C3:CT" & cntr).Clear
'Application.ScreenUpdating = False
'Start processing

With moHostExp
    For I = 3 To cntr
    msPlant = Worksheets(CO_DataSheet).Cells(I, 1)
    moHostExp.CursorRC 2, 71
    moHostExp.RunCmd "Erase-Input"
    moHostExp.PutText msPlant, 2, 71
    moHostExp.RunCmd "Enter"
    WaitForScreen
    
        .RunCmd "Home"
        .Keys "GCMMSGABA"
        .RunCmd "Enter"
        WaitForScreen
        msPartNumber = Worksheets(CO_DataSheet).Cells(I, 2)
        .CursorRC 3, 8
        .RunCmd "ERASE-LINE"
        .PutText msPartNumber, 3, 8
        .RunCmd "Enter"
        WaitForScreen
        Worksheets(CO_DataSheet).Cells(I, 3) = Trim(.TextRC(9, 16, 6)) 'Loose Fig
        Worksheets(CO_DataSheet).Cells(I, 4) = Trim(.TextRC(9, 22, 5)) 'Days Stock
        Worksheets(CO_DataSheet).Cells(I, 5) = Trim(.TextRC(11, 14, 8)) 'Will make Fig
        Worksheets(CO_DataSheet).Cells(I, 6) = Trim(.TextRC(11, 22, 5)) 'Days Stock
        Worksheets(CO_DataSheet).Cells(I, 7) = Trim(.TextRC(4, 69, 3)) 'R&FU Code
        Worksheets(CO_DataSheet).Cells(I, 8) = Trim(.TextRC(5, 13, 5)) 'GSDB Code
        Worksheets(CO_DataSheet).Cells(I, 9) = Trim(.TextRC(4, 9, 35)) 'Part description
        Worksheets(CO_DataSheet).Cells(I, 10) = Trim(.TextRC(3, 66, 1)) 'part status
        Worksheets(CO_DataSheet).Cells(I, 11) = Trim(.TextRC(20, 4, 74)) 'Live ASN
        Worksheets(CO_DataSheet).Cells(I, 12) = Trim(.TextRC(9, 45, 10)) 'Last Rec Date
        Worksheets(CO_DataSheet).Cells(I, 13) = Trim(.TextRC(8, 45, 10)) 'Last rec Qty
        Worksheets(CO_DataSheet).Cells(I, 14) = Trim(.TextRC(15, 75, 4)) 'container QTY
        'Bin Locs
        Worksheets(CO_DataSheet).Cells(I, 15) = Trim(.TextRC(8, 68, 10)) 'loc 1
        Worksheets(CO_DataSheet).Cells(I, 16) = Trim(.TextRC(9, 68, 10)) 'loc 2
        Worksheets(CO_DataSheet).Cells(I, 17) = Trim(.TextRC(10, 68, 10)) 'loc 3
        Worksheets(CO_DataSheet).Cells(I, 18) = Trim(.TextRC(11, 68, 2)) 'deck
        Worksheets(CO_DataSheet).Cells(I, 19) = Trim(.TextRC(5, 30, 30)) 'supplier
        

        WaitForScreen
        
    .RunCmd "Home"
    .Keys "GCMMSAAIA"
    .RunCmd "Enter"
    WaitForScreen
        
        If Trim(.TextRC(7, 2, 6)) = "" Then
            .CursorRC 3, 52
            .RunCmd "ERASE-LINE"
            .RunCmd "Enter"
            WaitForScreen
        End If
        
        If Trim(.TextRC(1, 2, 8)) = "CMMSANIA" Then
        
            For R = 9 To 20
                PCTBus = Trim(.TextRC(R, 36, 3))
                If Not PCTBus = "" Then
                    Exit For
                End If
            Next R
            .CursorRC R, 2
            .Keys "X"
            .RunCmd "Enter"
            WaitForScreen
        End If
        
        If Not Worksheets(CO_DataSheet).Cells(I, 8).Value = "" Then
            Worksheets(CO_DataSheet).Cells(I, 20).Value = Trim(.TextRC(18, 54, 25))
            Worksheets(CO_DataSheet).Cells(I, 21).Value = "'" & Trim(.TextRC(19, 54, 25))
            Worksheets(CO_DataSheet).Cells(I, 22).Value = Trim(.TextRC(8, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 23).Value = Trim(.TextRC(8, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 24).Value = Trim(.TextRC(9, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 25).Value = Trim(.TextRC(9, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 26).Value = Trim(.TextRC(10, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 27).Value = Trim(.TextRC(10, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 28).Value = Trim(.TextRC(11, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 29).Value = Trim(.TextRC(11, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 30).Value = Trim(.TextRC(12, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 31).Value = Trim(.TextRC(12, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 32).Value = Trim(.TextRC(13, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 33).Value = Trim(.TextRC(13, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 34).Value = Trim(.TextRC(14, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 35).Value = Trim(.TextRC(14, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 36).Value = Trim(.TextRC(15, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 37).Value = Trim(.TextRC(15, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 38).Value = Trim(.TextRC(16, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 39).Value = Trim(.TextRC(16, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 40).Value = Trim(.TextRC(17, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 41).Value = Trim(.TextRC(17, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 42).Value = Trim(.TextRC(18, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 43).Value = Trim(.TextRC(18, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 44).Value = Trim(.TextRC(19, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 45).Value = Trim(.TextRC(19, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 46).Value = Trim(.TextRC(20, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 47).Value = Trim(.TextRC(20, 13, 19))
            Worksheets(CO_DataSheet).Cells(I, 48).Value = Trim(.TextRC(21, 2, 8))
            Worksheets(CO_DataSheet).Cells(I, 49).Value = Trim(.TextRC(21, 13, 19))
            
            
           .RunCmd "Home"
        .Keys "GCMMSseba"
        .RunCmd "Enter"
        WaitForScreen

      

         Worksheets(CO_DataSheet).Cells(I, 61) = Trim(.TextRC(10, 14, 70)) 'function des 1
         
         WaitForScreen
            
            
            
            
         
        .RunCmd "Home"
        .Keys "GCMMSFBBA"
        .RunCmd "Enter"
        WaitForScreen

      

         Worksheets(CO_DataSheet).Cells(I, 50) = Trim(.TextRC(10, 14, 70)) 'function des 1
         Worksheets(CO_DataSheet).Cells(I, 51) = Trim(.TextRC(11, 14, 70)) 'function des 2
         Worksheets(CO_DataSheet).Cells(I, 52) = Trim(.TextRC(12, 14, 70)) 'function des 1
         Worksheets(CO_DataSheet).Cells(I, 53) = Trim(.TextRC(13, 14, 70)) 'function des 3
         Worksheets(CO_DataSheet).Cells(I, 54) = Trim(.TextRC(14, 14, 70)) 'function des 4
         Worksheets(CO_DataSheet).Cells(I, 55) = Trim(.TextRC(15, 14, 70)) 'function des 5
         Worksheets(CO_DataSheet).Cells(I, 56) = Trim(.TextRC(16, 14, 70)) 'function des 6
         Worksheets(CO_DataSheet).Cells(I, 57) = Trim(.TextRC(17, 14, 70)) 'function des 7
         Worksheets(CO_DataSheet).Cells(I, 58) = Trim(.TextRC(18, 14, 70)) 'function des 8
         Worksheets(CO_DataSheet).Cells(I, 59) = Trim(.TextRC(19, 14, 70)) 'function des 9
         Worksheets(CO_DataSheet).Cells(I, 60) = Trim(.TextRC(20, 14, 70)) 'function des 10
        ' Worksheets(CO_DataSheet).Cells(I, 61) = Trim(.TextRC(21, 14, 70)) 'function des 11
         'Worksheets(CO_DataSheet).Cells(I, 62) = Trim(.TextRC(22, 14, 70)) 'function des 12
         
         WaitForScreen
            
        End If
    Next I

End With

DisconnectFromSession
Application.ScreenUpdating = False
  Range("C2:CT1000").Select
    With Selection
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
       .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("B1").Select
    
   
Application.ScreenUpdating = True
MsgBox "Finished running script.", vbInformation

End Sub

'Writes a message and Status to the data sheet
Private Sub WriteLog(sStatus As String, sMsg As String)

  With Worksheets(CO_DataSheet)
    .Cells(mlDataRow, miStatusCol) = sStatus
    .Cells(mlDataRow, miMessageCol) = sMsg
  End With

End Sub

'Get the message from the bottom of the screen
Private Function ScreenMessage() As String
  
  On Error Resume Next
  ScreenMessage = Trim(moHostExp.TextRC(24, 2, 80))
  
End Function

'Connect to the Hummingbird Host Explorer session
Private Function ConnectToSession() As Boolean
  
  On Error GoTo Error_Handler
  
  Set moHostApp = New HostExApplication
  Set moHostExp = moHostApp.CurrentHost
  If moHostExp Is Nothing Then
    MsgBox "There is no '" & CO_HepFileName & "' Hummingbird session running.", vbCritical
    ConnectToSession = False
  Else
    ConnectToSession = True
  End If

  Exit Function

Error_Handler:
  ConnectToSession = False

End Function

'Disconnect from the Hummingbird Host Explorer session
Private Function DisconnectFromSession()

  On Error Resume Next
  
  Set moHostExp = Nothing
  Set moHostApp = Nothing

End Function

'Wait for the screen to refresh after an action key has been pressed (e.g. "Enter" of "Pf8")
Private Sub WaitForScreen()
  
  'Two loops, just to make sure...
  While moHostExp.Keyboard
  Wend
  
  While moHostExp.Keyboard
  Wend
  
End Sub

'Try to find and set variables pointing to the status and message columns in the data sheet. It creates these columns if they
'do not already exist.
Private Function SetStatusColumns() As Boolean
  Dim iCol As Integer
  
  miStatusCol = 0
  miMessageCol = 0
  
  'Try and find update status and message columns
  With Worksheets(CO_DataSheet)
    iCol = 1
    While .Cells(1, iCol) <> ""
      If .Cells(1, iCol) = CO_Status Then
        miStatusCol = iCol
      End If
      If .Cells(1, iCol) = CO_Message Then
        miMessageCol = iCol
      End If
      iCol = iCol + 1
    Wend
  
    'If an update status column does not exist then add it to the end
    If miStatusCol = 0 Then
      miStatusCol = AddHeading(CO_Status)
    End If
  
    'If an update message column does not exist then add it to the end
    If miMessageCol = 0 Then
      miMessageCol = AddHeading(CO_Message)
    End If
  
  End With
  
End Function

Private Function AddHeading(sHeading As String) As Integer
  Dim iCol As Integer
  
  'Find first non blank column heading
  iCol = 1
  While Worksheets(CO_DataSheet).Cells(1, iCol) <> ""
    iCol = iCol + 1
  Wend

  'Add the heading and set background colour
  Worksheets(CO_DataSheet).Cells(1, iCol) = sHeading
  Worksheets(CO_DataSheet).Cells(1, iCol).Interior.ColorIndex = 15
  
  'Set the borders
  With Worksheets(CO_DataSheet).Cells(1, iCol).Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
  End With
  With Worksheets(CO_DataSheet).Cells(1, iCol).Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
  End With
  With Worksheets(CO_DataSheet).Cells(1, iCol).Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
  End With
  With Worksheets(CO_DataSheet).Cells(1, iCol).Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
  End With

  AddHeading = iCol
  
  
End Function

Private Sub Workbook_Open()
  
  On Error Resume Next
  Application.CommandBars("Hummingbird").Controls(1).OnAction = "ThisWorkBook.RunScript"

End Sub

Sub RunScript2()
  
'On Error Resume Next

'Confirm that user wants to run the script
If MsgBox("Do you wish to run the Hummingbird script?", vbYesNo) = vbNo Then
    Exit Sub
End If
'Try and connect to the Hummingbird session
If Not ConnectToSession Then
Exit Sub
End If

'A bit of initialisation
'SetStatusColumns
'mlDataRow = 3
cntr = WorksheetFunction.CountA(Worksheets(CO_DataSheet).Columns(2)) + 1
Worksheets(CO_DataSheet).Range("C3:AX" & cntr).Clear
'Application.ScreenUpdating = False
'Start processing

With moHostExp
    For I = 3 To cntr
    msPlant = Worksheets(CO_DataSheet).Cells(I, 1)
    moHostExp.CursorRC 2, 71
    moHostExp.RunCmd "Erase-Input"
    moHostExp.PutText msPlant, 2, 71
    moHostExp.RunCmd "Enter"
    WaitForScreen
    
        .RunCmd "Home"
        .Keys "GCMMSGABA"
        .RunCmd "Enter"
        WaitForScreen
        msPartNumber = Worksheets(CO_DataSheet).Cells(I, 2)
        .CursorRC 3, 8
        .RunCmd "ERASE-LINE"
        .PutText msPartNumber, 3, 8
        .RunCmd "Enter"
        WaitForScreen
        Worksheets(CO_DataSheet).Cells(I, 3) = Trim(.TextRC(9, 16, 6)) 'Loose Fig
        Worksheets(CO_DataSheet).Cells(I, 4) = Trim(.TextRC(9, 22, 5)) 'Days Stock
        Worksheets(CO_DataSheet).Cells(I, 5) = Trim(.TextRC(11, 14, 8)) 'Will make Fig
        Worksheets(CO_DataSheet).Cells(I, 6) = Trim(.TextRC(11, 22, 5)) 'Days Stock
        Worksheets(CO_DataSheet).Cells(I, 7) = Trim(.TextRC(4, 69, 3)) 'R&FU Code
        Worksheets(CO_DataSheet).Cells(I, 8) = Trim(.TextRC(5, 13, 5)) 'GSDB Code
        Worksheets(CO_DataSheet).Cells(I, 9) = Trim(.TextRC(4, 9, 35)) 'Part description
        Worksheets(CO_DataSheet).Cells(I, 10) = Trim(.TextRC(3, 66, 1)) 'part status
        Worksheets(CO_DataSheet).Cells(I, 11) = Trim(.TextRC(20, 4, 74)) 'Live ASN
        Worksheets(CO_DataSheet).Cells(I, 12) = Trim(.TextRC(9, 45, 10)) 'Last Rec Date
        Worksheets(CO_DataSheet).Cells(I, 13) = Trim(.TextRC(8, 45, 10)) 'Last rec Qty
        Worksheets(CO_DataSheet).Cells(I, 14) = Trim(.TextRC(15, 75, 4)) 'container QTY
        'Bin Locs
        Worksheets(CO_DataSheet).Cells(I, 15) = Trim(.TextRC(8, 68, 10)) 'loc 1
        Worksheets(CO_DataSheet).Cells(I, 16) = Trim(.TextRC(9, 68, 10)) 'loc 2
        Worksheets(CO_DataSheet).Cells(I, 17) = Trim(.TextRC(10, 68, 10)) 'loc 3
        Worksheets(CO_DataSheet).Cells(I, 18) = Trim(.TextRC(11, 68, 2)) 'deck
        Worksheets(CO_DataSheet).Cells(I, 19) = Trim(.TextRC(5, 30, 30)) 'supplier
        

        WaitForScreen
        
        .RunCmd "Home"
        .Keys "GCMMSFBBA"
        .RunCmd "Enter"
        WaitForScreen
        msPartNumber = Worksheets(CO_DataSheet).Cells(I, 2)
        .CursorRC 3, 8
        .RunCmd "ERASE-LINE"
        .PutText msPartNumber, 3, 8
        .RunCmd "Enter"
        WaitForScreen

         Worksheets(CO_DataSheet).Cells(I, 50) = Trim(.TextRC(10, 14, 41)) 'function des 1
        
        
    .RunCmd "Home"
    .Keys "GCMMSAAIA"
    .RunCmd "Enter"
    WaitForScreen
        
        If Trim(.TextRC(7, 2, 6)) = "" Then
            .CursorRC 3, 52
            .RunCmd "ERASE-LINE"
            .RunCmd "Enter"
            WaitForScreen
        End If
        
        If Trim(.TextRC(1, 2, 8)) = "CMMSANIA" Then
        
            For R = 9 To 20
                PCTBus = Trim(.TextRC(R, 36, 3))
                If Not PCTBus = "" Then
                    Exit For
                End If
            Next R
            .CursorRC R, 2
            .Keys "X"
            .RunCmd "Enter"
            WaitForScreen
        End If
        
        If Not Worksheets(CO_DataSheet).Cells(I, 8).Value = "" Then
            Worksheets(CO_DataSheet).Cells(I, 20).Value = Trim(.TextRC(18, 54, 25))
            Worksheets(CO_DataSheet).Cells(I, 21).Value = "'" & Trim(.TextRC(19, 54, 25))
           ' Worksheets(CO_DataSheet).Cells(I, 22).Value = Trim(.TextRC(8, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 23).Value = Trim(.TextRC(8, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 24).Value = Trim(.TextRC(9, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 25).Value = Trim(.TextRC(9, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 26).Value = Trim(.TextRC(10, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 27).Value = Trim(.TextRC(10, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 28).Value = Trim(.TextRC(11, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 29).Value = Trim(.TextRC(11, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 30).Value = Trim(.TextRC(12, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 31).Value = Trim(.TextRC(12, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 32).Value = Trim(.TextRC(13, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 33).Value = Trim(.TextRC(13, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 34).Value = Trim(.TextRC(14, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 35).Value = Trim(.TextRC(14, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 36).Value = Trim(.TextRC(15, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 37).Value = Trim(.TextRC(15, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 38).Value = Trim(.TextRC(16, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 39).Value = Trim(.TextRC(16, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 40).Value = Trim(.TextRC(17, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 41).Value = Trim(.TextRC(17, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 42).Value = Trim(.TextRC(18, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 43).Value = Trim(.TextRC(18, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 44).Value = Trim(.TextRC(19, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 45).Value = Trim(.TextRC(19, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 46).Value = Trim(.TextRC(20, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 47).Value = Trim(.TextRC(20, 13, 19))
           ' Worksheets(CO_DataSheet).Cells(I, 48).Value = Trim(.TextRC(21, 2, 8))
           ' Worksheets(CO_DataSheet).Cells(I, 49).Value = Trim(.TextRC(21, 13, 19))
            
        End If
    Next I

End With

DisconnectFromSession
Application.ScreenUpdating = False
  Range("C2:Z1000").Select
    With Selection
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
       .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("B1").Select
Application.ScreenUpdating = True
MsgBox "Finished running script.", vbInformation

End Sub

Sub RunScript3()
  
'On Error Resume Next

'Confirm that user wants to run the script
If MsgBox("Do you wish to run the Hummingbird script?", vbYesNo) = vbNo Then
    Exit Sub
End If
'Try and connect to the Hummingbird session
If Not ConnectToSession Then
Exit Sub
End If

'A bit of initialisation
'SetStatusColumns
'mlDataRow = 3
cntr = WorksheetFunction.CountA(Worksheets(CO_DataSheet).Columns(2)) + 1
Worksheets(CO_DataSheet).Range("C3:AX" & cntr).Clear
'Application.ScreenUpdating = False
'Start processing

With moHostExp
    For I = 3 To cntr
    msPlant = Worksheets(CO_DataSheet).Cells(I, 1)
    moHostExp.CursorRC 2, 71
    moHostExp.RunCmd "Erase-Input"
    moHostExp.PutText msPlant, 2, 71
    moHostExp.RunCmd "Enter"
    WaitForScreen
    
        .RunCmd "Home"
        .Keys "GCMMSFBBA"
        .RunCmd "Enter"
        WaitForScreen
        msPartNumber = Worksheets(CO_DataSheet).Cells(I, 2)
        .CursorRC 3, 8
        .RunCmd "ERASE-LINE"
        .PutText msPartNumber, 3, 8
        .RunCmd "Enter"
        WaitForScreen

         Worksheets(CO_DataSheet).Cells(I, 50) = Trim(.TextRC(10, 14, 70)) 'function des 1
         Worksheets(CO_DataSheet).Cells(I, 51) = Trim(.TextRC(11, 14, 70)) 'function des 2
         Worksheets(CO_DataSheet).Cells(I, 52) = Trim(.TextRC(12, 14, 70)) 'function des 1
         Worksheets(CO_DataSheet).Cells(I, 53) = Trim(.TextRC(13, 14, 70)) 'function des 3
         Worksheets(CO_DataSheet).Cells(I, 54) = Trim(.TextRC(14, 14, 70)) 'function des 4
         Worksheets(CO_DataSheet).Cells(I, 55) = Trim(.TextRC(15, 14, 70)) 'function des 5
         Worksheets(CO_DataSheet).Cells(I, 56) = Trim(.TextRC(16, 14, 70)) 'function des 6
         Worksheets(CO_DataSheet).Cells(I, 57) = Trim(.TextRC(17, 14, 70)) 'function des 7
         Worksheets(CO_DataSheet).Cells(I, 58) = Trim(.TextRC(18, 14, 70)) 'function des 8
         Worksheets(CO_DataSheet).Cells(I, 59) = Trim(.TextRC(19, 14, 70)) 'function des 9
         Worksheets(CO_DataSheet).Cells(I, 60) = Trim(.TextRC(20, 14, 70)) 'function des 10
        ' Worksheets(CO_DataSheet).Cells(I, 61) = Trim(.TextRC(21, 14, 70)) 'function des 11
         'Worksheets(CO_DataSheet).Cells(I, 62) = Trim(.TextRC(22, 14, 70)) 'function des 12
          
        WaitForScreen
        
   
       
    Next I

End With

DisconnectFromSession
Application.ScreenUpdating = False
  Range("C2:Z1000").Select
    With Selection
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
       .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("B1").Select
Application.ScreenUpdating = True
MsgBox "Finished running script.", vbInformation

End Sub
Sub RunScript4()
  
'On Error Resume Next

'Confirm that user wants to run the script
If MsgBox("Do you wish to run the Hummingbird script?", vbYesNo) = vbNo Then
    Exit Sub
End If
'Try and connect to the Hummingbird session
If Not ConnectToSession Then
Exit Sub
End If

'A bit of initialisation
'SetStatusColumns
'mlDataRow = 3
cntr = WorksheetFunction.CountA(Worksheets(CO_DataSheet).Columns(2)) + 1
Worksheets(CO_DataSheet).Range("C3:CT" & cntr).Clear
'Application.ScreenUpdating = False
'Start processing

With moHostExp
    For I = 3 To cntr
    msPlant = Worksheets(CO_DataSheet).Cells(I, 1)
    moHostExp.CursorRC 2, 71
    moHostExp.RunCmd "Erase-Input"
    moHostExp.PutText msPlant, 2, 71
    moHostExp.RunCmd "Enter"
    WaitForScreen
    
        .RunCmd "Home"
        .Keys "GCMMSGABA"
        .RunCmd "Enter"
        WaitForScreen
        msPartNumber = Worksheets(CO_DataSheet).Cells(I, 2)
        .CursorRC 3, 8
        .RunCmd "ERASE-LINE"
        .PutText msPartNumber, 3, 8
        .RunCmd "Enter"
        WaitForScreen
        Worksheets(CO_DataSheet).Cells(I, 3) = Trim(.TextRC(9, 16, 6)) 'Loose Fig
        Worksheets(CO_DataSheet).Cells(I, 4) = Trim(.TextRC(9, 22, 5)) 'Days Stock
        Worksheets(CO_DataSheet).Cells(I, 5) = Trim(.TextRC(11, 14, 8)) 'Will make Fig
        Worksheets(CO_DataSheet).Cells(I, 6) = Trim(.TextRC(11, 22, 5)) 'Days Stock
        Worksheets(CO_DataSheet).Cells(I, 7) = Trim(.TextRC(4, 69, 3)) 'R&FU Code
        Worksheets(CO_DataSheet).Cells(I, 8) = Trim(.TextRC(5, 13, 5)) 'GSDB Code
        Worksheets(CO_DataSheet).Cells(I, 9) = Trim(.TextRC(4, 9, 35)) 'Part description
        Worksheets(CO_DataSheet).Cells(I, 10) = Trim(.TextRC(3, 66, 1)) 'part status
        Worksheets(CO_DataSheet).Cells(I, 11) = Trim(.TextRC(20, 4, 74)) 'Live ASN
        Worksheets(CO_DataSheet).Cells(I, 12) = Trim(.TextRC(9, 45, 10)) 'Last Rec Date
        Worksheets(CO_DataSheet).Cells(I, 13) = Trim(.TextRC(8, 45, 10)) 'Last rec Qty
        Worksheets(CO_DataSheet).Cells(I, 14) = Trim(.TextRC(15, 75, 4)) 'container QTY
        'Bin Locs
        Worksheets(CO_DataSheet).Cells(I, 15) = Trim(.TextRC(8, 68, 10)) 'loc 1
        Worksheets(CO_DataSheet).Cells(I, 16) = Trim(.TextRC(9, 68, 10)) 'loc 2
        Worksheets(CO_DataSheet).Cells(I, 17) = Trim(.TextRC(10, 68, 10)) 'loc 3
        Worksheets(CO_DataSheet).Cells(I, 18) = Trim(.TextRC(11, 68, 2)) 'deck
        Worksheets(CO_DataSheet).Cells(I, 19) = Trim(.TextRC(5, 30, 30)) 'supplier
        

        WaitForScreen
       
    Next I

End With

DisconnectFromSession
Application.ScreenUpdating = False
  Range("C2:CT1000").Select
    With Selection
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
       .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("B1").Select
    
   
Application.ScreenUpdating = True
MsgBox "Finished running script.", vbInformation

End Sub
 
Upvote 0
Update I was able to get this to work, my next problem is having 2 or more worksheet selection subs I'm aware it can be written into one, can anyone assist in helping me copy this code having it perform the same action but adding the below change, I want to be able to perform the same task but have it work by clicking in column B, can anyone assist please I'm just not sure how to combine, the idea is that I can make changes to the B column click so it will search another screen within the application,

Thanks in advance for any help

VBA Code: 
If Not Intersect(Target, Range("B2:B3000")) Is Nothing Then

VBA Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A2:A3000")) Is Nothing Then
Application.ScreenUpdating = False
    
    Worksheets("Data 3").Range("B5") = Range(Target.Address).Value
     

' If MsgBox("Do you wish to run the Hummingbird script?", vbYesNo) = vbNo Then
'    Exit Sub
'End If
'Try and connect to the Hummingbird session
'If Not ConnectToSession Then
'Exit Sub
'End If
   ConnectToSession
   
With moHostExp
    For I = 3 To cntr
    msPlant = Worksheets(CO_DataSheet).Range("B5")
    moHostExp.CursorRC 2, 71
    moHostExp.RunCmd "Erase-Input"
    moHostExp.PutText msPlant, 2, 71
    moHostExp.RunCmd "Enter"
    WaitForScreen
    
        .RunCmd "Home"
        .Keys "GCMMSGABA"
        .RunCmd "Enter"
        WaitForScreen
        msPartNumber = Worksheets(CO_DataSheet).Range("B5")
        .CursorRC 3, 8
        .RunCmd "ERASE-LINE"
        .PutText msPartNumber, 3, 8
        .RunCmd "Enter"
        WaitForScreen
 

      
 
 Application.ScreenUpdating = True
  
  
 
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Macro to track changes to multiple cells
2
Replies
17
Views
2K
Nicolaw81
N
I
  • Question
Modify VBA script to count rows with data in multiple sheets
Replies
0
Views
98
irishjsk
I
S
  • Question
Need code that adds multiple new rows to table to include a check box in column "L" for each new row
Replies
0
Views
340
sspatriots
S
N
  • Question
VBA for border lines between the cells with exact / different cell value whenever the autofilter changes
Replies
0
Views
448
NixaMKD
N
M
  • Question
Create button with update function for already present sheet
Replies
1
Views
471
SeniorNewbie
SeniorNewbie

Forum statistics

Threads
1,215,073
Messages
6,122,975
Members
449,095
Latest member
Mr Hughes

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top