End without with using excel and IBM 3270 terminal - excel

I am working on a macro to pull data of receipts and I need to only find the qty for today's receipts. Using the IBM terminal I bring up an excel worksheet and then proceed to make IBM go to screen I need and then look at the date on the screen and match it to the receipt date. if today's date doesn't match the receipt date on the first page then I need to have the macro press enter and then search the second page for the matching date and so on till the dates match or if they never do stop once the receipt date is blank. My code is below. Not sure where the open function is to not let the code finish. I am a novice and have no idea of formatting code, I apologize in advance.
Thanks for any help you provide.
Sub RMBR()
Dim infile As String
Dim part As String * 19, COMMENT As String * 7, COMMENT2 As String * 2
Dim TDATE As String * 7, PLANT As String * 1
Dim source As String
Dim SELECTION As Integer, i As Integer, c As String
Dim Result As Single
Dim excel As Object
Dim ACELL As Single, BCELL As Single, CCELL As Single, dcell As Single
Dim Verify As Single
infile = InputBox$("input FILE NAME INCLUDING PATH?", "FILE NAME", "C:\CFILES\rmbr.XLSX")
TDATE = InputBox$("Input Status", "TDATE", "CURRENT")
i = 2
Set excel = CreateObject("EXCEL.APPLICATION")
excel.Visible = True
excel.Workbooks.Open FileName:=infile
Verify = MsgBox("IS THIS THE CORRECT SPREADSHEET?", 4, "VERIFY SPREADSHEET")
ACELL = "A2"
BCELL = "B2"
CCELL = "C2"
DCELL = "D2"
excel.Range("A1").Select
excel.activecell.FormulaR1C1 = "PARTNO"
excel.Range("B1").Select
excel.activecell.FormulaR1C1 = "RMBR QTY"
excel.Range("C1").Select
excel.activecell.FormulaR1C1 = " "
excel.Range("D1").Select
excel.activecell.FormulaR1C1 = "TODAY'S DATE"
excel.Range(ACELL).Select
part = excel.activecell.FormulaR1C1
excel.Range(BCELL).Select
PLANT = excel.activecell.FormulaR1C1
excel.Range(CCELL).Select
COMMENT = excel.activecell.FormulaR1C1
excel.Range(dcell).Select
COMMENT2 = excel.activecell.FormulaR1C1
Do Until partnumber = " "
With Session
.TransmitTerminalKey rcIBMClearKey
.WaitForEvent rcKbdEnabled, "30", "0", 1, 1
.WaitForEvent rcEnterPos, "30", "0", 1, 1
.TransmitANSI "RMBR"
.TransmitTerminalKey rcIBMEnterKey
.WaitForEvent rcKbdEnabled, "30", "0", 1, 1
'.WaitForEvent rcEnterPos, "30", "0", 2, 6
.WaitForDisplayString "FN:", "30", 2, 2
.MoveCursor 4, 11
.TransmitANSI part
.TransmitTerminalKey rcIBMEnterKey
.WaitForEvent rcKbdEnabled, "30", "0", 1, 1
Date = .GetDisplayText(4, 73, 8)
RIP.Date = .GetDisplayText(9, 73, 8)
Dim n As Integer
For n = 9 To 22
Do Until Date = RIP.Date
Date = .GetDisplayText(9, 73, 8)
RIP.Date = .GetDisplayText(n, 73, 8)
Loop
If Date = RIP.Date Then
Result = .GetDisplayText(n, 32, 6)
excel.Range(BCELL).Select
excel.activecell.FormulaR1C1 = Result
End If
If Date <> RIP.Date Then
.TransmitTerminalKey rcIBMEnterKey
End If
Do Until Date = RIP.Date
Date = .GetDisplayText(9, 73, 8)
RIP.Date = .GetDisplayText(n, 73, 8)
Loop
Do Until RIP.Date = " "
Loop
i = i + 1
c = Trim$(Str$(i))
ACELL = "A" + c
BCELL = "B" + c
CCELL = "C" + c
excel.Range(ACELL).Select
part = excel.activecell.FormulaR1C1
excel.Range(BCELL).Select
PLANT = excel.activecell.FormulaR1C1
excel.Range(CCELL).Select
COMMENT = excel.activecell.FormulaR1C1
excel.Range(dcell).Select
COMMENT2 = excel.activecell.FormulaR1C1
End With
End Sub

There are quite some issues in your code, let's have a look:
Plenty of this:
excel.Range("A1").Select
excel.activecell.FormulaR1C1 = "PARTNO"
You can replace this by (far more readable):
excel.Range("A1").FormulaR1C1 = "PARTNO"
First:
i = 2
ACELL = "A2"
And later:
i = i + 1
c = Trim$(Str$(i))
ACELL = "A" + c
You can use this at the beginning too, so replace the first one by:
i = 2
c = Trim$(Str$(i))
ACELL = "A" + c
For-loop is not ended:
For n = 9 To 22
...
(Where's the Next, or the Step?)
Possible endless loop:
Do Until RIP.Date = " "
Loop
(Two things: this is a possible endless loop, and second, what's with the list of spaces? You'd better say "... until Trim$(RIP.Date) = """)
Also the large loop is not ended:
Do Until partnumber = " "
(same comment as above)
Please correct your code further (as your code does not even compile, it's almost impossible to help you further).
In top of this I see that you are mixing small letters and capitals. In Excel this is not a problem but other programming languages might have a problem with that. Please get a good habit of using the same "capitalising" system for all your variables.

Related

Transpose irregular data from .txt import to a table in Excel

I have imported a bunch of data from tables in Word -> .txt -> Excel, but in the conversion to .txt the format of the table is lost and I am now trying to recover it in Excel.
I would just make a simple Copy/Paste Macro based on the Cell Range, but the cell ranges are not the same across each imported .txt file so this won't work as the same data could be in A8 in one sheet then A10 in another.
You could almost move every other row into column B, but the "Date Due" field throws it out of sync.
I want to transpose the copied date into a more functional table format - see picture for example - which I can then analyze. I need to do this for hundreds of sheets but I'm hoping that if I can get it working for one then I can adapt it to work across many.
Each sheet may have multiple products, each new product is preceded by an integer (e.g. 1. Product1; 2. Product2 etc...)
deleted old code that I'd tried to do
EDIT2:
screenshot of typical notepad file
There is a load of text above this, but the first product always starts with QUOTATION MACHINE SCHEDULE, then 1. xxx
EDIT3:
Tried to add in the column I to have Quote Ref: and find this in the text file, but it didn't work. Code change from CDP1802 current solution below
'results sheet
Set ws = ThisWorkbook.Sheets("Results")
ws.Range("A1:I1") = Array("Item", "Date Due", "Type", "Serial Number", "Standard", "Mode", "Range", "Location", "Quote Ref:")
r = 1 ' output row
Select Case s
' match word to set column
Case "type": c = 3
Case "serial number": c = 4
Case "standard": c = 5
Case "mode": c = 6
Case "range": c = 7
Case "location": c = 8
Case "Quote Ref:": c = 9
Case Else: c = 0
End Select
New Screenshot for Quote Ref:
Read the text file into an array and then scan for key words using Select Case. Reading the data into an array allows you to select the value from the row below the key word.
update - Quote Ref added
Option Explicit
Sub ProcessTextFiles1()
Const FOLDER = "C:\temp\SO\Data\" ' folder where the text files are
Dim ws As Worksheet, sFilename As String, sQuoteRef As String
Dim n As Integer, i As Long, r As Long, c As Long
Dim fso As Object, ts As Object, ar() As String, s As String
Set fso = CreateObject("Scripting.FileSystemObject")
' results sheet
Set ws = ThisWorkbook.Sheets("Results")
ws.Range("A1:I1") = Array("Item", "Date Due", "Type", "Serial Number", _
"Standard", "Mode", "Range", "Location", "Quote Ref")
r = 1 ' output row
' scan each file in folder
sFilename = Dir(FOLDER & "*.txt")
Do While Len(sFilename) > 0
n = n + 1
sQuoteRef = ""
' open file and read into array
Set ts = fso.OpenTextFile(FOLDER & sFilename)
s = ts.readAll
s = Replace(s, vbLf, "")
ar = Split(s, vbCr)
ts.Close
'MsgBox sFilename & "=" & UBound(ar)
' parse the strings in the array
i = 0
Do While i <= UBound(ar)
s = LCase(Trim(ar(i)))
'Debug.Print s
If Len(s) > 0 Then ' skip blanks
If Left(s, 10) = "quote ref:" Then
sQuoteRef = ar(i + 1)
End If
If Left(s, 2) Like "#." Or Left(s, 3) Like "##." Then
' new product
r = r + 1
ws.Cells(r, 1) = ar(i)
ws.Cells(r, 9) = sQuoteRef
Else
Select Case s
' match word to set column
Case "type": c = 3
Case "serial number": c = 4
Case "standard": c = 5
Case "mode": c = 6
Case "range": c = 7
Case "location": c = 8
Case Else: c = 0
End Select
' take value below
If c = 4 Then
ws.Cells(r, 4) = ar(i + 1)
ws.Cells(r, 2) = ar(i + 2) ' due date
i = i + 2
ElseIf c > 1 Then
ws.Cells(r, c) = ar(i + 1)
i = i + 1
End If
End If
End If
i = i + 1
Loop
sFilename = Dir
Loop
MsgBox n & " Files processed", vbInformation
End Sub

Count number of occourences of specific values in a string

I have multiple rows with some words separeted by semicolons(;), and need to count how many times a certain word appears in Column A cell strings of Sheet1.
Using two rows for example:
Column "A"
Banana; Apple; Orange
Banana; Banana; Apple
I came up with this code for the counting of the specific word I want to count:
Sub count()
'The count will be registered in "B6"
strcount = "Banana"
For i = 2 to 30
If InStr(Sheets("Sheet1").Cells(i, "A").Text, strcount) <> 0 Then
Cells(6, "B").Value = Cells(6, "B").Value + 1
End If
Next i
End Sub
The problem with this code is that it doesn't recognize the 2 appearences of "Banana" in the second row returning me a count of 2 instead of 3:
Results for each fruit:
Banana: 2
Apple: 2
Orange: 1
I see that the problem is InStr only recognizes if the string is there, but how can I overcome this?
Solution:
Both basodre's and Алексей's answers worked.
For basodre's code I had to change only the delimiter from ";" to "; " (with a space after the semicolon) to match my string.
aFoods = Split(rIterator.Value, "; ")
Алексей's answer works perfectly too, but by the time of this edit is limited for Excel 2019 or above, given it uses the "TEXTJOIN" function and I couldn't come up with a replacement for that.
Here's an example that I think does what you need. Please review, modify to your range, and let us know if it works.
Sub CountWords()
Dim rng As Range
Dim aFoods As Variant
Dim rIterator As Range
Dim counter As Long
Const theFood As String = "Banana"
Set rng = Range("A1:A3")
counter = 0
For Each rIterator In rng
aFoods = Split(rIterator.Value, ";")
For i = LBound(aFoods) To UBound(aFoods)
If aFoods(i) = theFood Then
counter = counter + 1
End If
Next i
Next rIterator
Debug.Print counter
End Sub
Solution with RegExp:
Option Explicit
Sub test1()
Dim re As Object, result As Object, text As String, fruit As Variant
Set re = CreateObject("vbscript.regexp")
re.Global = True
text = WorksheetFunction.TextJoin(";", True, Columns("A"))
'In Excel < 2019 you can use: text = Join(WorksheetFunction.Transpose(Intersect(Columns("A"), ActiveSheet.UsedRange)), ";")
For Each fruit In Array("Banana", "Apple", "Orange")
re.Pattern = "\b" & fruit & "\b"
Set result = re.Execute(text)
Debug.Print "Amount of [" & fruit & "] = " & result.Count
Next
End Sub
Output:
Amount of [Banana] = 3
Amount of [Apple] = 2
Amount of [Orange] = 1
Using regular expression
Sub FindEntries()
Dim mc, rw
Const word$ = "Banana"
With CreateObject("VBScript.RegExp")
.IgnoreCase = True: .Global = True: .Pattern = "(^|;\s+)" & word & "(?=;|$)"
For rw = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Set mc = .Execute(Cells(rw, "A")): [B6] = [B6] + mc.Count
Next
End With
End Sub

How do i locate the variable that is the mismatch (Run-time error 13)

I'm trying to locate the variable mismatch in this code for my coworkers VBA code. Yet i've not been able to locate the problem. The code is supposed to update 2 different sheets based on manual inputs in a 3rd sheet. This is in regard to safety hazards.
The debug says this line of code is the one messing up
Previouscellcontentbefore = ActiveCell.Offset(rowbefore + 1, columbefore + 1)
The full code:
Dim I As Integer
Dim row As Integer
Dim before As String
Dim after As String
Dim cons As String
Dim conscat As String
Dim checks As String
Dim check2 As String
Dim check3 As String
Dim rowbefore As String
Dim columbefore As String
Dim rowafter As String
Dim columafter As String
Dim checkbefore As String
Dim checkafter As String
Dim Previouscellcontentbefore As Integer
Dim Previouscellcontentafter As Integer
Sheets("for calculations").Visible = True
cons = Application.InputBox(prompt:="Personnel; Environment; Assets; Reputation; All", Title:="Choose consequence (NB: Case sensitive)", Default:="All")
Worksheets("For calculations").Activate
Range("D37:I42").ClearContents
Range("L37:Q42").ClearContents
Range("C34").ClearContents
Select Case cons
Case "All"
Range("C34").Value = "Risk matrix shows all types of consequences"
Case "Personnel"
Range("C34").Value = "Risk matrix shows all types of Personnel consequences"
Case "Environment"
Range("C34").Value = "Risk matrix shows Environmental consequences"
Case "Asset"
Range("C34").Value = "Risk matrix shows Asset consequences"
Case "Reputation"
Range("C34").Value = "Risk matrix shows Reputation consequences"
End Select
For I = 1 To 200
Range("C47").Value = Worksheets("HAZIDS").Cells(I + 5, 2).Value
conscat = Range("F47")
check2 = cons Like conscat
check3 = cons Like "All"
If cons Like "All" Then
check2 = True
End If
If check2 Then
before = Range("D47")
after = Range("E47")
rowbefore = Mid(before, 2, 1)
columbefore = Mid(before, 4, 1)
rowafter = Mid(after, 2, 1)
columafter = Mid(after, 4, 1)
checkbefore = Not rowbefore Like "" And Not columbefore Like ""
checkafter = Not rowafter Like "" And Not columafter Like ""
If checkbefore Then
Range("C36").Select
Previouscellcontentbefore = ActiveCell.Offset(CInt(rowbefore) + 1, CInt(columbefore) + 1)
ActiveCell.Offset(CInt(rowbefore) + 1, CInt(columbefore) + 1) = Range("C47").Value & ", " & Previouscellcontentbefore
If checkafter Then
Range("K36").Select
Previouscellcontentafter = ActiveCell.Offset(CInt(rowafter) + 1, CInt(columafter) + 1)
ActiveCell.Offset(CInt(rowafter) + 1, CInt(columafter) + 1) = Range("C47").Value & ", " & Previouscellcontentafter
End If
End If
End If
End Sub
I expect the macro to update sheet "Risk matrix before" and "Risk matrix after" based on the manual inputs in "HAZIDS"
Yet the sheet "For calculations" seems to be buggy
You are doing
rowbefore = Mid(before, 2, 1) 'Rownumber in matrix before
columbefore = Mid(before, 4, 1) 'Columnumber in matrix before
And since you didn't declare these variables, they get a string value. (since Mid return a string)
After that in the line indicated by the debug you do this:
Previouscellcontentbefore = ActiveCell.Offset(rowbefore + 1, columbefore + 1)
You are adding integer value 1 to a string value, which doesn't make sense.
What you need to do is use option explicit and properly define your variables.
Then you might need to convert your strings into integers with the function Cint like this
Previouscellcontentbefore = ActiveCell.Offset(Cint(rowbefore) + 1, Cint(columbefore) + 1)
This will only work if your rowbefore and columnbefore actually contain a string that can be converted to an integer. If not you will get an error.

Excel VBA convert Date with time

I have 2 cells with time data that format as follows:
"A1" = Sep 01 2018 00:01:33.707
"A2" = Sep 01 2018 00:01:49.917
I need to create a button and method within excel VBA that will set "A3" cell to true if the time "A2" is more than "A1" by 90 seconds.
This is what i have so far but it does not work:
Sub Macro2()
Dim str1 As String, str2 As String
With Worksheets("sheet5")
str1 = .Cells(1, "A").Text
str2 = .Cells(2, "A").Text
'greater than 90m seconds in A3
.Cells(3, "A") = CBool(Abs((DateValue(Left(str1, 6) & "," & Mid(str1, 7, 5)) + _
TimeValue(Mid(str1, 13, 8)) + TimeSerial(0, 0, 1) * CDbl(Right(str1, 4))) - _
(DateValue(Left(str2, 6) & "," & Mid(str2, 7, 5)) + _
TimeValue(Mid(str2, 13, 8)) + TimeSerial(0, 0, 1) * CDbl(Right(str2, 4)))) > _
TimeSerial(0, 0, 90))
'actual absolute difference in A4
.Cells(4, "A") = Abs((DateValue(Left(str1, 6) & "," & Mid(str1, 7, 5)) + _
TimeValue(Mid(str1, 13, 8)) + TimeSerial(0, 0, 1) * CDbl(Right(str1, 4))) - _
(DateValue(Left(str2, 6) & "," & Mid(str2, 7, 5)) + _
TimeValue(Mid(str2, 13, 8)) + TimeSerial(0, 0, 1) * CDbl(Right(str2, 4))))
End With End Sub
The above gives error because Date functions works with system Locale, which in my case is Hebrew, while the Data is in English.
Another way that could help is to convert all the column "A" (which holds the dates) to a system local date that can be used with Date and time functions on VBA (don't know how to do that).
Please help
I have split your task into 3 functions.
a) a helper function converts the 3 characters of the month into an integer. It looks a little clumsy, there might be other approaches but the advantage of using a large Select Case is it is easy to understand and easy to adapt if month names in a different language arise:
Function getMonthFromName(monthName As String) As Integer
Select Case UCase(monthName)
Case "JAN": getMonthFromName = 1
Case "FEB": getMonthFromName = 2
Case "MAR": getMonthFromName = 3
Case "APR": getMonthFromName = 4
(...)
Case "SEP": getMonthFromName = 9
(...)
End Select
End Function
b) a function that converts the string into a date. It assumes the date format in the form you provided, but it is easily adapted if the format changes (for simplicity, the seconds are rounded)
Function GetDateFromString(dt As String) As Date
Dim tokens() As String
tokens = Split(Replace(dt, ":", " "), " ")
Dim day As Integer, month As Integer, year As Integer
month = getMonthFromName(CStr(tokens(0)))
day = Val(tokens(1))
year = Val(tokens(2))
Dim hour As Integer, minute As Integer, second As Double
hour = Val(tokens(3))
minute = Val(tokens(4))
second = Round(Val(tokens(5)), 0)
GetDateFromString = DateSerial(year, month, day) + TimeSerial(hour, minute, second)
End Function
c) A function that calculated the difference of the 2 dates in seconds. A date in VBA (and many other environments) is stored as Double, where the Date-Part is the integer part and the date is the remainder. This makes it easy to calculate with Date values.
Function DateDiffInSeconds(d1 As String, d2 As String) As Long
Dim diff As Double
diff = GetDateFromString(d2) - GetDateFromString(d1)
DateDiffInSeconds = diff * 24 * 60 * 60
End Function
Update to deal with milliseconds: Change the GetDateFromString-function. In that case, DateDiffInSeconds should return a double rather than a long.
Function GetDateFromString(dt As String) As Date
Const MillSecPerHour As Long = 24& * 60 * 60 * 1000
Dim tokens() As String
tokens = Split(Replace(Replace(dt, ".", " "), ":", " "), " ")
Dim day As Integer, month As Integer, year As Integer
month = getMonthFromName(CStr(tokens(0)))
day = Val(tokens(1))
year = Val(tokens(2))
Dim hour As Integer, minute As Integer, second As Integer, milli As Integer
hour = Val(tokens(3))
minute = Val(tokens(4))
second = Val(tokens(5))
milli = Val(tokens(6))
GetDateFromString = DateSerial(year, month, day) _
+ TimeSerial(hour, minute, second) _
+ milli / MillSecPerHour
End Function
For your information, I've done what you are doing in a slightly different (and easier) way:
In cell B2, I put the value 13/11/2018 11:44:00.
In cell B3, I put the value 13/11/2018 11:45:01.
(For both cells, the cell formatting has been set to d/mm/jjjj u:mm:ss).
In another cell, I put following formula:
=IF((B3-B2)*86400>90;TRUE;FALSE)
The formula is based on the idea that a datetime value is set, based on the idea that one day equals 1, and there are 86400 seconds in one day.
Like this, you can calculate time differences without needing VBA.
I think you are over-complicating it, try this to get an idea how to do it:
Sub Macro2()
Dim str1 As String, str2 As String
With Worksheets("sheet5")
.Range("b1:e1") = Split(Range("A1"), " ")
.Range("B2:e2") = Split(Range("A2"), " ")
End Sub
Use UDF.
Sub Macro2()
Dim str1 As String, str2 As String
Dim mySecond As Double, t1 As Double, t2 As Double, t3 As Double
mySecond = TimeSerial(0, 0, 90)
With Worksheets("sheet5")
str1 = .Cells(1, "A").Text
str2 = .Cells(2, "A").Text
t1 = ConvertTime(str1)
t2 = ConvertTime(str2)
t3 = t2 - t1
.Cells(3, "a") = Abs(t3) >= mySecond
End With
End Sub
Function ConvertTime(s As String)
Dim vS
vS = Split(s, " ")
ConvertTime = DateValue(vS(0) & "-" & vS(1) & "-" & vS(2)) + TimeValue(Split(vS(3), ".")(0))
End Function

Excel Vba getting value of cell and setting a string

I want to set a string as a certain letter based on the value of a cell. The cell should only have the values, "P1", "P2", "P3", "P4". If the cell is "P1" then I want to set the string "products2" as "a", if its "P2" I want "products2" set as "b" ...
Here is the code, which will get the correct value for the cell, but wont use it to set the products2.
Dim Products As String
Dim Products2 As String
Products = wash.offset(1, 3).Value
If Products = P1 Then
Products2 = "a"
ElseIf Products = P2 Then
MsgBox "we got here"
Products2 = "b"
End If
MsgBox "products2 = " & Products2
Here is a version that will do what you want, and extend it to P3 etc. I had to set wash to some location to get the code to work. It assumes that the value in the cell you are accessing is of the form Pi where i is an integer. It gets the value of i, shifted down by 1, then obtains gets the letter in the alphabet shifted by i (so "a" for 0, "b" for 1, etc.)
Sub ProdString()
Dim Products As String
Dim Products2 As String
Dim i As Long
Dim wash as Range
Set wash = Range("A1")
Products = wash.Offset(1, 3).Value
Products = Mid(Trim(Products), 2) 'strip off the "P"
i = Val(Trim(Products)) - 1
Products2 = Chr(i + Asc("a"))
MsgBox "Products2 = " & Products2
End Sub
The way it exists right now, it is trying to compare products to a variable rather than a string
Dim Products As String
Dim Products2 As String
Products = cstr(trim(wash.offset(1, 3).Value))
If Products = "P1" Then
Products2 = "a"
ElseIf Products = "P2" Then
MsgBox "we got here"
Products2 = "b"
End If
MsgBox "products2 = " & Products2
A good way to extend it so it easily covers "P1" through "P4" would be to use a select statement as follows:
Products = CStr(Trim(wash.Offset(1, 3).value))
Select Case Products
Case "P1":
Products2 = "a"
Case "P2":
Products2 = "b"
Case "P3":
Products2 = "c"
Case "P4":
Products2 = "d"
End Select
MsgBox "products2 = " & Products2
It's a lot easier to scan while reading.
My attempt
Function StrOut(strIn As String)
StrOut = Chr(96 + CLng(Replace(strIn, "P", vbNullString)))
End Function
test
Sub TestDaCode()
Debug.Print StrOut("P1")
Debug.Print StrOut("P2")
End Sub

Resources