I'm working on a large Excel project that requires entering a lot of data spread out over the worksheet that needs to be entered as quick as possible. To try and aide with the entry, I've created a number of UserForms that the user would enter the data into. One such form returns the above "Process Too Large" error when trying to transfer the data.
I understand why the error pops up - it's far too long. I've included the code for one such entry (slightly modified of course) and was wondering how I would be able to truncate it?
Dim ws As Worksheet
Dim i As Long
Set ws = ThisWorkbook.Sheets("STOCK")
' 101
If entry101.Value <> "" Then
Dim NUM101 As String
If com101.Value <> "" Then
NUM101 = "# - " & UCase(com101.Value)
Else
NUM101 = ""
End If
If cmb101.Value = "FULL" Then
ws.Range("_101").Value = UCase(code101.Value) & " " & Chr(10) & UCase(com101.Value) & " - FULL " & Chr(10) & " "
End If
If cmb101.Value = "OUT OF STOCK" Then
ws.Range("_101").Value = UCase(com101.Value) & " OUT OF STOCK " & Chr(10) & UCase(code101.Value) & " " & Chr(10) & " "
End If
If cmb101.Value = "SHIPPED" Then
ws.Range("_101").Value = UCase(code101.Value) & " " & Chr(10) & " - SHIPPED " & Chr(10) & NUM101
End If
If cmb101.Value = "DAMAGED" Then
ws.Range("_101").Value = UCase(code101.Value) & " DAMAGED " & Chr(10) & " "" & Chr(10) & NUM101"
End If
If cmb101.Value = "LOW STOCK" Then
ws.Range("_101").Value = UCase(com101.Value) & " LOW-STOCK " & Chr(10) & UCase(code101.Value) & " " & Chr(10) & " "
End If
If cmb101.Value = "RETURN" Then
ws.Range("_101").Value = UCase(code101.Value) & " " & Chr(10) & "RETURNED - " & UCase(com101.Value) & " " & Chr(10) & " "
End If
If cmb101.Value = "" Then
ws.Range("_101").Value = UCase(code101.Value) & Chr(10) & " - UNKNOWN CONDITION"
End If
End If
The UserForm has two text boxes ("code101" & "com101") and a single ComboBox ("cmb101") for each entry. The above code needs to be applied to a range from "_101" to "_143" so needs to repeat 43 times.
Any help would be greatly appreciated. Thank you all.
Something like this (untested):
Dim ws As Worksheet, vCom, vCode
Dim i As Long, s, num As String
Set ws = ThisWorkbook.Sheets("STOCK")
For i = 101 To 143
If Me.Controls("entry" & i).Value <> "" Then
vCom = UCase(Me.Controls("com" & i).Value)
vCode = UCase(Me.Controls("code" & i).Value)
num = IIf(vCom <> "", "# - " & vCom, "")
s = ""
Select Case Me.Controls("cmb" & i).Value
Case "FULL": s = vCode & " " & Chr(10) & vCom & " - FULL " & Chr(10) & " "
Case "OUT OF STOCK": s = vCom & " OUT OF STOCK " & Chr(10) & vCode & " " & Chr(10) & " "
Case "SHIPPED": s = vCode & " " & Chr(10) & " - SHIPPED " & Chr(10) & num
'etc
'etc
End Select
If Len(s) > 0 Then ws.Range("_" & i).Value = s
End If
Next i
Related
This question already has answers here:
Better way to find last used row
(9 answers)
Closed 10 months ago.
I've created a program that is supposed to select an entire column and autofill it to the end starting with a formula that will ALWAYS be in a fixed spot on the column. However, the issue is that in terms of row numbers, the number changes daily, so I can't hardcode an ending range.
I tried to do this:
Range("W11").Select
ActiveCell.FormulaR1C1 = _
"=IF([#COMPANY]&[#Whse]=""R01""," & Chr(10) & " R[-1]C-IF([#BOQty]="""",0,[#BOQty])" & Chr(10) & " +IF([#[R01-PO QTY]]="""",0,[#[R01-PO QTY]])" & Chr(10) & " +IF([#[R01-ALC QTY]]="""",0,[#[R01-ALC QTY]])" & Chr(10) & " +IF([#[R01-JOB QTY]]="""",0,[#[R01-JOB QTY]])" & Chr(10) & " +IF([#[R01-GIT QTY]]="""",0,[#[R01-GIT QTY]])," & Chr(10) & "R[-1]C)"
Range("W11").Select
Selection.AutoFill Destination:=Range("W11:W")
But it returns a "Method Range of Object _Global failed.
What do I do instead? How do I select the entire column AFTER W11 in this case?
I got this working. If anyone is wondering what I did, I did it in a sort of roundabout way. I first created a function called GetLastRow
Function GetLastRow(Strt As String, Cur As String)
'''''
'Get the row of the last line of data
'''''
GetLastRow = Range(Strt, Range(Cur).End(xlDown)).Rows.Count
If GetLastRow > 1000000 Then
GetLastRow = ElimAlpha(Cur)
End If
End Function
I then created some Dims to get the last row for EACH of my columns. Worked beautifully.
Sub RunningBalances()
Dim NumRows01 As Integer
Dim NumRows02 As Integer
Dim NumRowsRDS As Integer
Dim NumRows1 As Integer
Dim NumRowsPDS As Integer
'
' RunningBalances Macro
'
'
'CompanyR W/H 01
NumRows01 = GetLastRow("W11", "W11" & VBA.CStr(StrtPOs))
Range("W11").Select
ActiveCell.FormulaR1C1 = _
"=IF([#COMPANY]&[#Whse]=""R01""," & Chr(10) & " R[-1]C-IF([#BOQty]="""",0,[#BOQty])" & Chr(10) & " +IF([#[R01-PO QTY]]="""",0,[#[R01-PO QTY]])" & Chr(10) & " +IF([#[R01-ALC QTY]]="""",0,[#[R01-ALC QTY]])" & Chr(10) & " +IF([#[R01-JOB QTY]]="""",0,[#[R01-JOB QTY]])" & Chr(10) & " +IF([#[R01-GIT QTY]]="""",0,[#[R01-GIT QTY]])," & Chr(10) & "R[-1]C)"
Selection.AutoFill Destination:=Range("W11" & ":W" & NumRows01)
'CompanyR W/H 02
NumRows02 = GetLastRow("AF11", "AF11" & VBA.CStr(StrtPOs))
Range("AF11").Select
ActiveCell.FormulaR1C1 = _
"=IF([#COMPANY]&[#Whse]=""R02""," & Chr(10) & " R[-1]C-IF([#BOQty]="""",0,[#BOQty])" & Chr(10) & " +IF([#[R02-PO QTY]]="""",0,[#[R02-PO QTY]])" & Chr(10) & " +IF([#[R02-ALC QTY]]="""",0,[#[R02-ALC QTY]])" & Chr(10) & " +IF([#[R02-JOB QTY]]="""",0,[#[R02-JOB QTY]])" & Chr(10) & " +IF([#[R02-GIT QTY]]="""",0,[#[R02-GIT QTY]])," & Chr(10) & "R[-1]C)"
Selection.AutoFill Destination:=Range("AF11" & ":AF" & NumRows02)
'CompanyR W/H DS
NumRowsRDS = GetLastRow("AO11", "AO11" & VBA.CStr(StrtPOs))
Range("AO11").Select
ActiveCell.FormulaR1C1 = _
"=IF([#COMPANY]&[#Whse]=""RDS""," & Chr(10) & " R[-1]C-IF([#BOQty]="""",0,[#BOQty])" & Chr(10) & " +IF([#[RDS-PO QTY]]="""",0,[#[RDS-PO QTY]])" & Chr(10) & " +IF([#[RDS-ALC QTY]]="""",0,[#[RDS-ALC QTY]])" & Chr(10) & " +IF([#[RDS-JOB QTY]]="""",0,[#[RDS-JOB QTY]])" & Chr(10) & " +IF([#[RDS-GIT QTY]]="""",0,[#[RDS-GIT QTY]])," & Chr(10) & "R[-1]C)"
Selection.AutoFill Destination:=Range("AO11" & ":AO" & NumRowsRDS)
'CompanyP W/H 1
NumRows1 = GetLastRow("AX11", "AX11" & VBA.CStr(StrtPOs))
Range("AX11").Select
ActiveCell.FormulaR1C1 = _
"=IF([#COMPANY]&[#Whse]=""P1""," & Chr(10) & " R[-1]C-IF([#BOQty]="""",0,[#BOQty])" & Chr(10) & " +IF([#[P1-PO QTY]]="""",0,[#[P1-PO QTY]])" & Chr(10) & " +IF([#[P1-ALC QTY]]="""",0,[#[P1-ALC QTY]])" & Chr(10) & " +IF([#[P1-JOB QTY]]="""",0,[#[P1-JOB QTY]])" & Chr(10) & " +IF([#[P1-GIT QTY]]="""",0,[#[P1-GIT QTY]])," & Chr(10) & "R[-1]C)"
Selection.AutoFill Destination:=Range("AX11" & ":AX" & NumRows1)
'CompanyP W/H DS
NumRowsPDS = GetLastRow("BG11", "BG11" & VBA.CStr(StrtPOs))
Range("BG11").Select
ActiveCell.FormulaR1C1 = _
"=IF([#COMPANY]&[#Whse]=""R02""," & Chr(10) & " R[-1]C-IF([#BOQty]="""",0,[#BOQty])" & Chr(10) & " +IF([#[PDS-PO QTY]]="""",0,[#[PDS-PO QTY]])" & Chr(10) & " +IF([#[PDS-ALC QTY]]="""",0,[#[PDS-ALC QTY]])" & Chr(10) & " +IF([#[PDS-JOB QTY]]="""",0,[#[PDS-JOB QTY]])" & Chr(10) & " +IF([#[PDS-GIT QTY]]="""",0,[#[PDS-GIT QTY]])," & Chr(10) & "R[-1]C)"
Selection.AutoFill Destination:=Range("BG11" & ":BG" & NumRowsPDS)
In General: I'm trying to create a sub that runs multiple queries. All of these queries are exactly similar except for one word: Column1. Therefore I'd like to use a loop and replace Column1 with a function GetColumnAct(x). The function should return Column1 when running the loop the first time, Column2 when running it the second time and so on...
Here's the code:
Sub ColumnLoop()
For x = 1 To 5
ActiveWorkbook.Queries.Add Name:=GetColumnAct(x), Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Quelle = Excel.Workbook(File.Contents(""C:\Users\felix\OneDrive\Dokumente\GIZ Consultancy\Technisch\Teststruktur\FV_MA_Abfragen\Aktuelle Abfrage NEU\MA_Daten_AktuelleAbfrageNEU.xlsx""), null, true)," & Chr(13) & "" & Chr(10) & " Tabelle1_Sheet = Quelle{[Item=""Tabelle1"",Kind=""Sheet""]}[Data]," & Chr(13) & "" & Chr(10) & " #""Höher gestufte Header"" = Table.PromoteHeaders(Tabelle1_Sheet, [PromoteAllScalars=true]" & _
")," & Chr(13) & "" & Chr(10) & " #""Spalte nach Trennzeichen teilen"" = Table.SplitColumn(#""Höher gestufte Header"", ""Mitarbeiter (eMail) TN-Projekt"", Splitter.SplitTextByDelimiter("","", QuoteStyle.Csv), {""MA.1"", ""MA.2"", ""MA.3""})," & Chr(13) & "" & Chr(10) & " #""Zusammengeführte Abfragen"" = Table.NestedJoin(#""Spalte nach Trennzeichen teilen"", {""TN Projekt""}, Tabelle1, {""TN Projekt""}, ""Tabelle1"", JoinKind.FullOuter)," & Chr(13) & "" & Chr(10) & " #""Erweiterte Tabelle1"" = Table.ExpandTableColumn(#""Zusammengeführte Abfragen"", ""Tabelle1"", {""TN Projekt"", ""Fachverbunds Nr."", ""TN Bezeichnung"", ""Fachverbundsbezeichnung"", ""MA.1"", ""MA.2"", ""MA.3""}, {""Tabelle1.TN Projekt"", ""Tabelle1.Fachverbunds Nr."", ""Tabelle1.TN Bezeichnung"", ""Tabelle1.Fachverbundsbezeichnung"", ""Tabelle1.MA.1"", ""Tabelle1.MA.2"", ""Tabelle1.MA.3""})," & Chr(13) & "" & Chr(10) & " #""Entfernte Spalten"" = Table.RemoveColumns(#""Erweiterte Tabelle1"",{""Tabelle1.TN Projekt"", ""Tabelle1.Fachverbunds Nr."", ""Tabelle1.TN Bezeichnung"", ""Tabelle1.Fachverbundsbezeichnung""})," & Chr(13) & "" & Chr(10) & " #""Tiefer gestufte Header"" = Table.Demote" & _
"Headers(#""Entfernte Spalten"")," & Chr(13) & "" & Chr(10) & " #""Transponierte Tabelle"" = Table.Transpose(#""Tiefer gestufte Header"")," & Chr(13) & "" & Chr(10) & " ColumnNext = #""Transponierte Tabelle"" [GetColumnAct(x)]," & Chr(13) & "" & Chr(10) & " #""In Tabelle konvertiert"" = Table.FromList(ColumnNext, Splitter.SplitByNothing(), null, null, ExtraValues.Error)," & Chr(13) & "" & Chr(10) & " #""Entfernte Duplikate"" = Table.Distinct(#""In Tabelle konvertiert"")," & Chr(13) & "" & Chr(10) & " #""" & _
"Entfernte leere Zeilen"" = Table.SelectRows(#""Entfernte Duplikate"", each not List.IsEmpty(List.RemoveMatchingItems(Record.FieldValues(_), {"""", null})))," & Chr(13) & "" & Chr(10) & " #""Transponierte Tabelle1"" = Table.Transpose(#""Entfernte leere Zeilen"")" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Transponierte Tabelle1"""
Next x
End Sub
And the function is this:
Public Function GetColumnAct(ColNumber) As String
Dim ColumnAct As String
ColumnAct = "Column" & ColNumber
GetColumnAct = ColumnAct
End Function
The only problem is the inclusion of the function GetColumnAct(x) in the formula. While it works for the Argument Name:=GetColumnAct(x), (at the beginning) it doesn't work when included in Formula:=... (at the end).
Does anybody know why this is so? Maybe I'm just getting the syntax wrong? I'm super thankful for any help provided as I'm stuck on this mini thing the whole day now...
Here's the error message I get in advanced editor (power query):
invalid identifier
Try this:
Public Function GetColumnAct(ColNumber as Integer) As String
Dim ColumnAct As String
ColumnAct = "Column" & str(ColNumber)
GetColumnAct = ColumnAct
End Function
thanks again to everybody who looked into this!
I've now found the answer!
Instead of
#""Transponierte Tabelle"" [GetColumnAct(x)]," & Chr(13) & ""
I needed to write
#""Transponierte Tabelle"" [" & GetColumnAct(x) & "]," & Chr(13) & ""
Somebody told me at another website, so glad I've got it now!
I have the following listed in my Sheet 1 code, moving cell values to the body of an Outlook email.
I'm trying to STOP inserting text for the given line if the cell in Column A is empty.
Private Sub CommandButton1_Click()
'Create email with attachment, subject, and list of email addresses
ThisWorkbook.Save
Dim outlookApp As Object
Dim myMail As Object
Dim Source_File, to_emails, cc_emails As String
Dim file_to_send As String
Dim body_code As String
Dim i As Integer
Set outlookApp = CreateObject("Outlook.Application")
Set myMail = outlookApp.CreateItem(olMailItem)
For i = 2 To 22
to_emails = to_emails & Cells(i, 13) & ";"
'for CC: change the 13 to whatever column count from the left where your CC list is
'cc_emails = cc_emails & Cells(i, 13) & ";"
Next i
Source_File = ThisWorkbook.FullName
myMail.Attachments.Add Source_File
'myMail.CC = cc_emails
myMail.To = to_emails
myMail.Subject = Range("Q2").Value & " 10-8 Form " & Format(Date, "mm/dd/yy")
myMail.Body = Range("B2") & " Shift" & " - " & Format(Date, "mmmm dd, yyyy") _
& vbNewLine & vbNewLine & "Sergeant: " & Range("A6") & ", " & Range("B6") & vbNewLine & " Status: " & Range("C6") _
& vbNewLine & vbNewLine & "Corporal: " & Range("A8") & ", " & Range("B8") & vbNewLine & " Status: " & Range("C8") _
& vbNewLine & vbNewLine & "Assigned Deputies" & vbNewLine & vbNewLine & _
Range("A10") & ", " & Range("B10") & vbNewLine & " Assignment/Zone: " & Range("C10") & vbNewLine & _
Range("A11") & ", " & Range("B11") & vbNewLine & " Assignment/Zone: " & Range("C11") & vbNewLine & _
Range("A12") & ", " & Range("B12") & vbNewLine & " Assignment/Zone: " & Range("C12") & vbNewLine & _
Range("A13") & ", " & Range("B13") & vbNewLine & " Assignment/Zone: " & Range("C13") & vbNewLine & _
Range("A14") & ", " & Range("B14") & vbNewLine & " Assignment/Zone: " & Range("C14") & vbNewLine & _
Range("A15") & ", " & Range("B15") & vbNewLine & " Assignment/Zone: " & Range("C15") & vbNewLine & _
Range("A16") & ", " & Range("B16") & vbNewLine & " Assignment/Zone: " & Range("C16") & vbNewLine & _
Range("A17") & ", " & Range("B17") & vbNewLine & " Assignment/Zone: " & Range("C17") & vbNewLine & _
Range("A18") & ", " & Range("B18") & vbNewLine & " Assignment/Zone: " & Range("C18")
myMail.Display
ThisWorkbook.Save
End Sub
I would definitely break up that huge wall of text you have. This can be done with a loop.
Let's use a For loop here.
Dim concatString as String
For i = 10 To 18
If Not Cells(i, "A").Text = vbNullString Then
'Add to growing string
concatString = concatString + Cells(i, "A").Text & ", " & Cells(i, "B").Text & vbCr
concatString = concatString + "Assignment/Zone: " & Cells(i, "C").Text & vbCr
End If
Next i
If column A contains an empty string, we skip over it and move to the next row.
I posted this before you added more code, but I think you get the idea. Break up the huge chunk of code, and put only one cycle through columns A, B, and C in the loop. Adjust your loop constraints as necessary.
Here's what it would look like in your code:
'...
'your code here
'...
Dim concatString as String
For i = 10 To 18
If Not Cells(i, "A").Text = vbNullString Then
'Add to growing string
concatString = concatString + Cells(i, "A").Text & ", " & Cells(i, "B").Text & vbCr
concatString = concatString + "Assignment/Zone: " & Cells(i, "C").Text & vbCr
End If
Next i
myMail.Body = Range("B2") & " Shift" & " - " & Format(Date, "mmmm dd, yyyy") _
& vbNewLine & vbNewLine & "Sergeant: " & Range("A6") & ", " & Range("B6") & vbNewLine & " Status: " & Range("C6") _
& vbNewLine & vbNewLine & "Corporal: " & Range("A8") & ", " & Range("B8") & vbNewLine & " Status: " & Range("C8") _
& vbNewLine & vbNewLine & "Assigned Deputies" & vbNewLine & vbNewLine & concatString
I removed all those extra spaces, not sure if you actually need them in there or if it's a vestige of copying/pasting from VBE.
Here is the final code, the one that finally did it. Thank you to jclasley
`Private Sub CommandButton1_Click()
'Create email with attachment, subject, and list of email addresses
ThisWorkbook.Save
Dim outlookApp As Object
Dim myMail As Object
Dim Source_File, to_emails, cc_emails As String
Dim file_to_send As String
Dim i As Integer
Dim concatString As String
Set outlookApp = CreateObject("Outlook.Application")
Set myMail = outlookApp.CreateItem(olMailItem)
For i = 2 To 22
to_emails = to_emails & Cells(i, "M") & ";"
'for CC: change the 13 to whatever column count from the left where your CC list is
'cc_emails = cc_emails & Cells(i, 13) & ";"
Next i
Source_File = ThisWorkbook.FullName
myMail.Attachments.Add Source_File
'myMail.CC = cc_emails
myMail.To = to_emails
myMail.Subject = Range("Q2").Value & " 10-8 Form " & Format(Date, "mm/dd/yy")
For i = 10 To 18
If Not Cells(i, "A").Text = vbNullString Then
'Add to growing string
concatString = concatString + Cells(i, "A").Text & ", " & Cells(i, "B").Text & vbCr
concatString = concatString + "Assignment/Zone: " & Cells(i, "C").Text & vbNewLine & vbCr
End If
Next i
myMail.Body = Range("B2") & " Shift" & " - " & Format(Date, "mmmm dd, yyyy") _
& vbNewLine & vbNewLine & "Sergeant: " & Range("A6") & ", " & Range("B6") & vbNewLine & " Status: " & Range("C6") _
& vbNewLine & vbNewLine & "Corporal: " & Range("A8") & ", " & Range("B8") & vbNewLine & " Status: " & Range("C8") _
& vbNewLine & vbNewLine & "Assigned Deputies" & vbNewLine & vbNewLine & concatString
myMail.Display
ThisWorkbook.Save
End Sub
enter code here
I'm getting the 462 runtime error when updating an Access table from Excel VBA. I think the references are correctly qualified with the object variable as described here and here, but I'm still getting an error on the line where the number of records is assigned to dbImageCount using DCount.
Run-Time error '462': The remote server machine does not exist or is unavailable
Public AppAccess As Access.Application
...
Sub btnSave2Access_Click()
Dim MyRow As Long, LastCaptionRow As Integer
Dim sPath As String, STblName As String, CatalogNum As String, LotNum As String
Dim i As Integer, dbImageCount As Integer
CatalogNum = Trim(Sheets("Tier2Worksheet").Range("B2"))
LotNum = Trim(Sheets("Tier2Worksheet").Range("B3"))
LastCaptionRow = Range("E1000").End(xlUp).Row
sPath = Sheets("Settings").Range("B16")
STblName = "tblProductPictures"
Set AppAccess = New Access.Application
With AppAccess
.OpenCurrentDatabase sPath
For i = 1 To LastCaptionRow
'error in next line
dbImageCount = DCount("[SortOrder]", STblName, "[CatalogNum] = '" & CatalogNum & "' AND [LotNum] = '" & LotNum & "'") 'get current image count in DB for catNum/LotNum combo
While dbImageCount < LastCaptionRow 'adds record to picture table when required
dbImageCount = dbImageCount + 1
.DoCmd.RunSQL "INSERT INTO " & STblName & " (CatalogNum, LotNum, SortOrder) VALUES ('" & CatalogNum & "','" & LotNum & "','" & dbImageCount & "');"
DoEvents
Wend
With .DoCmd
.SetWarnings False
.RunSQL "UPDATE " & STblName & " SET PicPath='" & Range("E" & i) & "' Where [CatalogNum]='" & CatalogNum & "' and [SortOrder]='" & i & "' and [LotNum]='" & LotNum & "';"
.RunSQL "UPDATE " & STblName & " SET FullCaption='" & Range("D" & i) & "' Where [CatalogNum]='" & CatalogNum & "' and [SortOrder]='" & i & "' and [LotNum]='" & LotNum & "';"
.SetWarnings True
End With
Next i
.CloseCurrentDatabase
.Quit
End With
Set AppAccess = Nothing
Application.StatusBar = False
End Sub
Manually setting the value of dbImageCount on the fly during debug (commenting out the DCount line) properly updates the database with the new picture data.
It's important to note that this problem does not occur consistently. After months of use, the error did not creep up until this week and even then it didn't happen for every update attempt. In addition, it never happened during development (on a different system).
At first, I thought it was a network glitch or something of the like, but then I read that the 426 error is specifically an Office automation problem, so I expect that we will see it again soon.
You need to use DCount as a method of the Access Application:
With AppAccess
.OpenCurrentDatabase sPath
For i = 1 To LastCaptionRow
'error in next line
dbImageCount = .DCount("[SortOrder]", STblName, "[CatalogNum] = '" & CatalogNum & "' AND [LotNum] = '" & LotNum & "'") 'get current image count in DB for catNum/LotNum combo
While dbImageCount < LastCaptionRow 'adds record to picture table when required
dbImageCount = dbImageCount + 1
.DoCmd.RunSQL "INSERT INTO " & STblName & " (CatalogNum, LotNum, SortOrder) VALUES ('" & CatalogNum & "','" & LotNum & "','" & dbImageCount & "');"
DoEvents
Wend
With .DoCmd
.SetWarnings False
.RunSQL "UPDATE " & STblName & " SET PicPath='" & Range("E" & i) & "' Where [CatalogNum]='" & CatalogNum & "' and [SortOrder]='" & i & "' and [LotNum]='" & LotNum & "';"
.RunSQL "UPDATE " & STblName & " SET FullCaption='" & Range("D" & i) & "' Where [CatalogNum]='" & CatalogNum & "' and [SortOrder]='" & i & "' and [LotNum]='" & LotNum & "';"
.SetWarnings True
End With
Next i
.CloseCurrentDatabase
.Quit
End With
The below excel 2010 vba runs perfectly except I can not seem to get the variable process (time elapsed) to print from the Call Perl section to the analysis.txt, which captures some information regarding the analysis. Thank you :).
Private Sub CommandButton3_Click()
Dim MyBarCode As String ' Enter Barcode
Dim MyScan As String ' Enter ScanDate
Dim MyDirectory As String
'GET USER INPUT '
Line1:
MyBarCode = Application.InputBox("Please enter the last 5 digits of the barcode", "Bar Code", Type:=2)
If MyBarCode = "False" Then Exit Sub 'user canceled
Do
MyScan = Application.InputBox("Please enter scan date", "Scan Date", Date - 1, Type:=2)
If MyScan = "False" Then Exit Sub 'user canceled
If IsDate(MyScan) Then Exit Do
MsgBox "Please enter a valid date format. ", vbExclamation, "Invalid Date Entry"
Loop
'CREATE NEXUS DIRECTORY AND VERIFY FOLDER '
MyDirectory = "N:\1_DATA\MicroArray\NexusData\" & "2571683" & MyBarCode & "_" & Format(CDate(MyScan), "m-d-yyyy") & "\"
If Dir(MyDirectory, vbDirectory) = "" Then
MkDir MyDirectory
Else
MsgBox ("Already exsists! Please enter again")
GoTo Line1
End If
'Write to text file
Open MyDirectory & "sample_descriptor.txt" For Output As #1
Print #1, "Experiment Sample" & vbTab & "Control Sample" & vbTab & "Display Name" & vbTab & "Gender" & vbTab & "Control Gender" & vbTab & "Spikein" & vbTab & "Location" & vbTab & "Barcode" & vbTab & "Medical Record" & vbTab & "Date of Birth" & vbTab & "Order Date"
Print #1, "2571683" & MyBarCode & "_532Block1.txt" & vbTab & "2571683" & MyBarCode & "_635Block1.txt" & vbTab & ActiveSheet.Range("B8").Value & " " & ActiveSheet.Range("B9").Value & vbTab & ActiveSheet.Range("B10").Value & vbTab & ActiveSheet.Range("B5").Value & vbTab & ActiveSheet.Range("B11").Value & vbTab & ActiveSheet.Range("B12").Value & vbTab & "2571683" & MyBarCode & vbTab & ActiveSheet.Range("C201").Value & vbTab & ActiveSheet.Range("D201").Value & vbTab & ActiveSheet.Range("E201").Value
Print #1, "2571683" & MyBarCode & "_532Block2.txt" & vbTab & "2571683" & MyBarCode & "_635Block2.txt" & vbTab & ActiveSheet.Range("C8").Value & " " & ActiveSheet.Range("C9").Value & vbTab & ActiveSheet.Range("C10").Value & vbTab & ActiveSheet.Range("C5").Value & vbTab & ActiveSheet.Range("C11").Value & vbTab & ActiveSheet.Range("C12").Value & vbTab & "2571683" & MyBarCode & vbTab & ActiveSheet.Range("C202").Value & vbTab & ActiveSheet.Range("D202").Value & vbTab & ActiveSheet.Range("E202").Value
Print #1, "2571683" & MyBarCode & "_532Block3.txt" & vbTab & "2571683" & MyBarCode & "_635Block3.txt" & vbTab & ActiveSheet.Range("D8").Value & " " & ActiveSheet.Range("D9").Value & vbTab & ActiveSheet.Range("D10").Value & vbTab & ActiveSheet.Range("D5").Value & vbTab & ActiveSheet.Range("D11").Value & vbTab & ActiveSheet.Range("D12").Value & vbTab & "2571683" & MyBarCode & vbTab & ActiveSheet.Range("C203").Value & vbTab & ActiveSheet.Range("D203").Value & vbTab & ActiveSheet.Range("E203").Value
Print #1, "2571683" & MyBarCode & "_532Block4.txt" & vbTab & "2571683" & MyBarCode & "_635Block4.txt" & vbTab & ActiveSheet.Range("E8").Value & " " & ActiveSheet.Range("E9").Value & vbTab & ActiveSheet.Range("E10").Value & vbTab & ActiveSheet.Range("E5").Value & vbTab & ActiveSheet.Range("E11").Value & vbTab & ActiveSheet.Range("E12").Value & vbTab & "2571683" & MyBarCode & vbTab & ActiveSheet.Range("C201").Value & vbTab & ActiveSheet.Range("D204").Value & vbTab & ActiveSheet.Range("E204").Value
Close #1
'CREATE ANALYSIS LOG '
Dim Process As String
Open MyDirectory & "analysis.txt" For Output As #2
Print #2, "Analysis done by" & " " & Environ("UserName") & " " & "on" & " " & Date & " " & "at" & " " & Time & " " & "and took" & Process & "to complete"
Close #2
'CONFIRM ENTRIES '
Dim Patient As String
Dim Barcode As String
Dim Directory As String
Dim MyFile As Variant
Dim MyFolder As String
Dim i As Long
Directory = "N:\1_DATA\MicroArray\NexusData\" & "2571683" & MyBarCode & "_" & Format(CDate(MyScan), "m-d-yyyy")
Patient = ActiveSheet.Range("B9").Value & " " & ActiveSheet.Range("C9").Value & " " & ActiveSheet.Range("D9").Value & " " & ActiveSheet.Range("E9").Value
Barcode = "2571683" & MyBarCode
MsgBox "The patients that will be analyzed are:" + Patient & "The barcode is:" + Barcode
iYesNo = MsgBox("Do the patients and barcode match the setup sheet?", vbYesNoCancel)
Select Case iYesNo
Case vbYes
GoTo Line2
Case vbNo
MsgBox ("Doesn't match! Please enter again")
Call DeleteFolder(Directory)
GoTo Line1
End Select
'ADD VBA REFERENCE: MICROSOFT XML, v3.0 or v6.0 '
Line2:
Dim oXMLFile As New MSXML2.DOMDocument
Dim imgNode As MSXML2.IXMLDOMNodeList, destNode As MSXML2.IXMLDOMNodeList
Dim XMLFileName As String
XMLFileName = "C:\Users\cmccabe\Desktop\EmArray\Design\imagene.bch"
oXMLFile.Load (XMLFileName)
'EXTRACT NODES INTO LIST AND REWRITE NODES '
Set imgNode = oXMLFile.DocumentElement.SelectNodes("/Batch/Entry/Image")
imgNode(0).Text = "I:\" & "2571683" & MyBarCode & "_532.tif"
imgNode(1).Text = "I:\" & "2571683" & MyBarCode & "_635.tif"
Set destNode = oXMLFile.DocumentElement.SelectNodes("/Batch/Entry/Destination")
destNode(0).Text = MyDirectory
destNode(1).Text = MyDirectory
'SAVE UPDATED XML '
oXMLFile.Save XMLFileName
'UNINTIALIZE OBJECTS '
Set imgNode = Nothing
Set destNode = Nothing
Set oXMLFile = Nothing
'CALCULATE TIME FOR PROCESS '
Dim StartTime As Double
Dim MinutesElapsed As String
StartTime = Timer ' define start time
'CALL JAVA PROGRAM USING SHELL AND COMPLETE PROCESS '
Dim wshell As Object
Set wshell = CreateObject("wscript.shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
wshell.Run Chr(34) & "C:\Users\cmccabe\Desktop\EmArray\Design\java.bat", windowsStyle, waitOnReturn
'UPDATE PERL VARIABLES USING SHELL '
Dim PerlCommand As String, PerlParameters As String, VarDirectory As String
Dim var As String, var1 As String, var2 As String, var3 As String
MsgBox ("Verifying spike-ins, please wait")
VarDirectory = "N:\1_DATA\MicroArray\NexusData\" & "2571683" & MyBarCode & "_" & Format(CDate(MyScan), "m-d-yyyy")
var = VarDirectory
var1 = "sample_descriptor.txt"
var2 = "C:\cygwin\home\cmccabe\test_probes8.txt"
var3 = var & "\" & "output.txt"
'CALL PERL '
PerlCommand = """C:\Users\cmccabe\Desktop\EmArray\Design\perl.bat"""
PerlParameters = """" & var & """" & " " & _
"""" & var1 & """" & " " & _
"""" & var2 & """" & " " & _
"""" & var3 & """"
CreateObject("wscript.shell").Run PerlCommand & " " & PerlParameters, windowsStyle, waitOnReturn
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss") 'elapsed seconds
Process = MinutesElapsed & " minutes"
iYesNo = MsgBox("ImaGene and spike-in anlysis complete, do you want to run NxClinical?", vbYesNoCancel)
Select Case iYesNo
Case vbYes
'CALL AND EXECUTE NXCLINICAL '
Dim x As Variant
Dim Path As String
'SET INSTALLATION PATH '
Path = "C:\Program Files\BioDiscovery\NxClinical Client\NxClinical.exe"
x = Shell(Path, vbNormalFocus)
Case vbNo
'CLOSE AND EXIT '
Application.DisplayAlerts = False
Application.Quit
End Select
End Sub