Let say
Sub test()
Worksheets("1").Cells(1, 1).Value = "html"
Worksheets("1").Cells(1, 2).Value = "<xml xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" > "
txt = " '" & Worksheets("1").Cells(1, 1) & "'=>array('" & Worksheets("1").Cells(1, 2) & "' => $" & Worksheets("1").Cells(1, 1) & "),"
MsgBox txt
FilePath = Application.DefaultFilePath & "\array.txt"
Open FilePath For Output As #2
Write #2, txt
Close #2
End Sub
Now compare msgbox output with array.txt file.
So all my txt string became quoted, also added additional quotes to url, how to prevent changes and get string as it is.
Question is how to put msgbox output in array.txt ?
Sub test()
Worksheets("1").Cells(1, 1).Value = "html"
Worksheets("1").Cells(1, 2).Value = "<xml xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" > "
txt = " '" & Worksheets("1").Cells(1, 1) & "'=>array('" & Worksheets("1").Cells(1, 2) & "' => $" & Worksheets("1").Cells(1, 1) & "),"
MsgBox txt
FilePath = Application.DefaultFilePath & "\array.txt"
Open FilePath For Output As #2
Print #2, txt
Close #2
End Sub
Related
I've spent some time in developing these functions, but i want to make it more convenient because i have roughly 50++ of excel workbook in one folder. My codes is not suitable for 50++ of excel workbook. I need some guides on how to do it in bulk without declaring all those path and put it in the Sub Combineheader() as shown in below. Can anyone enlighten me with this part? I do have limited skills for excel VBA and still learning. Hopefully i can make this thread useful to other as well. Thank you.
Sub Combineheader()
/* The two subs below are having different path location for the output*/
/* if i have 50++ path location, i will be copy and paste for 50++ times */
CreateEJV1
CreateEJV2
End Sub
Sub CreateEJV1()
Dim myFfile As String
myFfile = "C:\Summary e-jv\AJSB\1.SAL-E-MTH.xlsx"
Application.Workbooks.Open Filename:=myFfile
DatFile1Name = ThisWorkbook.Path + "\Testing1.txt"
Open DatFile1Name For Output As #2 'create csv file
vRow = 2
While Cells(vRow, 1).Value <> ""
field1 = Cells(vRow, 1).Value
field2 = Cells(vRow, 2).Value
field3 = Cells(vRow, 3).Value
field4 = Cells(vRow, 4).Value
field5 = Cells(vRow, 5).Value
field6 = Cells(vRow, 6).Value
Dim str As String /* all of my workbooks are having the same format */
str = ""
str = field1 & " " & field2 & " " & field3 & " " & field4 & " " & field5 & " " & field6
Print #2, str
vRow = vRow + 1
Wend
If IsEmpty(Range("A2").Value) = True Then
Msg = "Error # " & Err.Number & " was generated by E-JV Excel Macro" _
& Err.Source & Chr(13) & "Error Line: " & "THERE ARE Details found " & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Close #2
ActiveWorkbook.Close
MsgBox ("File TESTING1.TXT created")
End Sub
Sub CreateEJV2()
Dim myFfile As String
myFfile = "C:\Summary e-jv\AJSB\2.IA-E-SAL.xlsx"
Application.Workbooks.Open Filename:=myFfile
DatFile1Name = ThisWorkbook.Path + "\Testing2.txt"
Open DatFile1Name For Output As #2 'create csv file
vRow = 2
While Cells(vRow, 1).Value <> ""
field1 = Cells(vRow, 1).Value
field2 = Cells(vRow, 2).Value
field3 = Cells(vRow, 3).Value
field4 = Cells(vRow, 4).Value
field5 = Cells(vRow, 5).Value
field6 = Cells(vRow, 6).Value
Dim str As String /* all of my workbooks are having the same format */
str = ""
str = field1 & " " & field2 & " " & field3 & " " & field4 & " " & field5 & " " & field6
Print #2, str
vRow = vRow + 1
Wend
If IsEmpty(Range("A2").Value) = True Then
Msg = "Error # " & Err.Number & " was generated by E-JV Excel Macro" _
& Err.Source & Chr(13) & "Error Line: " & "THERE ARE Details found " & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Close #2
ActiveWorkbook.Close
MsgBox ("File TESTING2.TXT created")
End Sub
This is what I mean - add two parameters to the sub which reads/writes the files, and call it with different file names:
Sub Combineheader()
CreateEJ "C:\Summary e-jv\AJSB\1.SAL-E-MTH.xlsx", _
ThisWorkbook.Path & "\Testing1.txt"
CreateEJ "C:\Summary e-jv\AJSB\2.IA-E-SAL.xlsx", _
ThisWorkbook.Path & "\Testing2.txt"
'etc...
End Sub
Sub CreateEJ(srcFile As String, destFile As String)
Dim wb As Workbook, sht As Worksheet, rw As Range
Set wb = Workbooks.Open(Filename:=srcFile)
Set sht = wb.Sheets(1)
Set rw = sht.Rows(2) '<< start on row2
If rw.Cells(1) <> "" Then
Open destFile For Output As #1 'create csv file
Do While rw.Cells(1) <> ""
Print #1, rw.Cells(1) & " " & rw.Cells(2) & " " & rw.Cells(3) & _
" " & rw.Cells(4) & " " & rw.Cells(5) & " " & rw.Cells(6)
Set rw = rw.Offset(1, 0) 'next row
Loop
Close #1
Debug.Print "Created output: " & destFile
Else
'no content in file?
MsgBox "File '" & wb.Name & "' has no content", vbExclamation
End If
wb.Close False 'don't save
End Sub
This code is designed to detect the columns of start and finish of a shape which is used and displayed onto the caption of the shape itself. The following code is the problematic code:
Sub Take_Baseline()
Dim forcast_weeksStart() As String
Dim forcast_weeksEnd() As String
Dim forcastDate As String
Dim shp As Shape
Dim split_text() As String
'cycle through all the shapes in the worsheet and enter the forcast date for all the projects into their respective boxes
For Each shp In ActiveSheet.Shapes
'initialize forcast date by parsing
forcast_weeksStart = Split(shp.TopLeftCell.Column.Text, " ")
forcast_weeksEnd = Split(shp.BottomRightCell.Column.Text, " ")
forcastDate = forcast_weeksStart(1) & "-" & forcast_weeksEnd(1)
temp = shp.OLEFormat.Object.Object.Caption
If InStr(temp, "/-/") > 0 & InStr(temp, "In Prog") Then
split_text = Split(shp.OLEFormat.Object.Caption, " ")
For i = 0 To (i = 3)
shp.TextFrame.Characters.Caption = split_text(i) & vbNewLine
Next i
ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption = ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption & vbNewLine & ActiveSheet.Cells(4, AShape.TopLeftCell.Column).Text & " - " & ActiveSheet.Cells(4, AShape.BottomRightCell.Column).Text & vbNewLine & "dates: " & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & "/" & "actualDate"
' ElseIf InStr(temp, "/-/") > 0 & InStr(temp, "In Prog") = 0 Then
'split_text = Split(shp.OLEFormat.Object.Object.Caption, " ")
' For i = 0 To (i = 2)
' shp.OLEFormat.Object.Caption = split_text(i) & vbNewLine
' Next i
'ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption = ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption & vbNewLine & "In Prog" & vbNewLine & ActiveSheet.Cells(4, AShape.TopLeftCell.Column).Text & " - " & ActiveSheet.Cells(4, AShape.BottomRightCell.Column).Text & vbNewLine & "dates: " & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & "actualDate"
End If
Next shp
'For testing purposes
Sheet4.Range("A20").Value = forcast_weeksStart(1)
Sheet4.Range("A21").Value = forcast_weeksEnd(1) End Sub
The error is an
"invalid qualifier"
message which occurs on line
forcast_weeksStart = Split(shp.TopLeftCell.Column.Text, " ")
Right on the "column" word. I don't get why this is happening since the actual drop down menu has the column operation which i can select. I have tried everything from changing it to the OLEformat.Object.Caption etc etc. But nothing has worked. I am still relatively new to vba so any help will be appreciated. Thanks
I have code in Excel which sends email to a list of recipients:
Sub SendEMail()
Dim xEmail As String
Dim xSubj As String
Dim xMsg As String
Dim xURL As String
Dim i As Integer
Dim k As Double
Dim xCell As Range
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", "Send emails to:", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count <> 3 Then
MsgBox "Incorrect number of columns: You have to choose Name, Email address, Account no.!"
Exit Sub
End If
For i = 1 To xRg.Rows.Count
' Get the email address
xEmail = xRg.Cells(i, 2)
' Message subject
xSubj = "Your customer's account is on hold"
' Compose the message
xMsg = ""
xMsg = xMsg & "Dear client" & "," & vbCrLf & vbCrLf
xMsg = xMsg & "We would like to inform you, that Your account has been put on hold - "
xMsg = xMsg & xRg.Cells(i, 3).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "If you have any queries, please contact us on uk.ar#bodycote.com." & vbCrLf & vbCrLf
xMsg = xMsg & "Kind regards," & vbCrLf
xMsg = xMsg & "Jon and Martina"
' Replace spaces with %20 (hex)
xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
' Replace carriage returns with %0D%0A (hex)
xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
' Create the URL
xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
' Wait two seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Next
End Sub
I would like to add variable attachments. It will be a pdf file and its name will be the same as the name of customer (which is placed in column A). Basically it should look for "Name.pdf" in "S:\All Team\AX OTI\test\"
The source table looks like:
Please try to use the below code.
xMsg = xMsg & "Dear client" & xRg.Cells(i, 1) & "," & vbCrLf & vbCrLf 'Added the client Name (optional) you can remove it
xMsg = xMsg & "We would like to inform you, that Your account has been put on hold - "
xMsg = xMsg & xRg.Cells(i, 3).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "If you have any queries, please contact us on uk.ar#bodycote.com." & vbCrLf & vbCrLf
xMsg = xMsg & "Kind regards," & vbCrLf
xMsg = xMsg & "Jon and Martina" & vbCrLf & vbCrLf 'Added two break point
' Replace spaces with %20 (hex)
xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
' Replace carriage returns with %0D%0A (hex)
xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
' Create the URL
xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg &"&attachment=S:\All Team\AX OTI\test\" & Cells(i,1) & ".pdf" 'Changed to this
' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
' Wait two seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Based on #Vityata advice, I've checked the question and based on that, I' ve changed the code. It is tested and works smoothly. The code is much easier, but the job is done.
Sub SendEmail()
Dim Mail_Object, OutApp As Variant
With ActiveSheet
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row 'list of recipients (email address) - it takes as many addresses as B column contains
End With
For i = 2 To lastrow
Set Mail_Object = CreateObject("Outlook.Application")
Set OutApp = Mail_Object.CreateItem(0)
With OutApp
.Subject = "Your customer's account is on hold"
.Body = "Dear client" & "," & vbCrLf & vbCrLf & "We would like to inform you, that Your account has been put on hold." & vbCrLf & vbCrLf & "If you have any queries, please contact us on uk.ar#bodycote.com." & vbCrLf & vbCrLf & "Kind regards," & vbCrLf & "Jon and Martina"
.To = Cells(i, 2).Value
strLocation = "S:\All team\AX OTI\test\" & Cells(i, 1) & ".pdf"
.Attachments.Add (strLocation)
.display
'.send
End With
Next i
debugs:
If Err.Description <> "" Then MsgBox Err.Description
End Sub
Here you have something that works really nicely - Add attachement to outlook with varying file names
In your case, simply copy the code and make sure that in the part strLocation you write something like:
strLocation = "C:\Users\user\Desktop\" & Cells(i,2) & ".pdf"
thus, you will be able to loop around it. In general, take a good look at the mentioned answer, it is really a good approach (IMHO quite better than sending keys).
I've created a macro that's meant to created a lump of CSS & HTML from a set of values in each sheet of a spreadsheet.
It's a little untidy as I created the function to write it from one sheet first as a proof of concept, and then updated it.
It doesn't throw any obvious errors, but the output varies, sometimes it shows the same thing both times, and then depending on where I've got debug MsgBoxs or watches in VBA seems to alter the output.
Any ideas what on earth i'm doing wrong?
Sub createCode()
Dim myWorkbook As Workbook
Dim mySheet As Worksheet
Set myWorkbook = Application.ActiveWorkbook
For Each mySheet In myWorkbook.Worksheets
Dim bannerCount As Integer
Dim BannerCollection() As Banner
Dim r As Range
Dim lastRow, lastCol
Dim allCells As Range
bannerCount = 0
lastCol = mySheet.Range("a2").End(xlToRight).Column
lastRow = mySheet.Range("a2").End(xlDown).Row
Set allCells = mySheet.Range("a2", mySheet.Cells(lastRow, lastCol))
' MsgBox (mySheet.Name)
' MsgBox ("lastRow:" & lastRow & "lastCol:" & lastCol)
ReDim BannerCollection(allCells.Rows.Count)
For Each r In allCells.Rows
Dim thisBanner As Banner
thisBanner.imagePath = ""
thisBanner.retImagePath = ""
thisBanner.bannerTitle = ""
thisBanner.urlPath = ""
bannerCount = bannerCount + 1
' MsgBox (bannerCount)
thisBanner.imagePath = Cells(r.Row, 2).Value
thisBanner.retImagePath = Cells(r.Row, 3).Value
thisBanner.bannerTitle = Cells(r.Row, 4).Value
thisBanner.urlPath = Cells(r.Row, 5).Value
'MsgBox (Cells(r.Row, 2).Value)
'MsgBox (Cells(r.Row, 3).Value)
'MsgBox (Cells(r.Row, 4).Value)
'MsgBox (Cells(r.Row, 5).Value)
BannerCollection(bannerCount - 1) = thisBanner
Next r
Dim i As Variant
Dim retinaCSS, imgCSS, firstBannerCode, otherBannersCode, bannerTracking As String
retinaCSS = ""
imgCSS = ""
firstBannerCode = ""
otherBannersCode = ""
bannerTracking = ""
For i = 0 To bannerCount - 1
bannerTracking = BannerCollection(i).bannerTitle
bannerTracking = Replace(bannerTracking, " ", "+")
bannerTracking = Replace(bannerTracking, "&", "And")
bannerTracking = Replace(bannerTracking, "%", "PC")
bannerTracking = Replace(bannerTracking, "!", "")
bannerTracking = Replace(bannerTracking, "£", "")
bannerTracking = Replace(bannerTracking, ",", "")
bannerTracking = Replace(bannerTracking, "'", "")
bannerTracking = Replace(bannerTracking, "#", "")
bannerTracking = Replace(bannerTracking, ".", "")
retinaCSS = retinaCSS & "#sliderTarget .banner-" & i + 1 & "{background-image: url('/assets/static/" & BannerCollection(i).retImagePath & "');}" & vbNewLine
imgCSS = imgCSS & "#sliderTarget .banner-" & i + 1 & "{background-image: url('/assets/static/" & BannerCollection(i).imagePath & "');}" & vbNewLine
If i = 0 Then
firstBannerCode = firstBannerCode & "<div class=" & Chr(34) & "banner banner-" & i + 1 & " staticBanner" & Chr(34) & ">" & vbNewLine
firstBannerCode = firstBannerCode & "" & vbNewLine
firstBannerCode = firstBannerCode & "</div>" & vbNewLine
Else
otherBannersCode = otherBannersCode & "<div class=" & Chr(34) & "banner banner-" & i + 1 & " staticBanner" & Chr(34) & ">" & vbNewLine
otherBannersCode = otherBannersCode & "" & vbNewLine
otherBannersCode = otherBannersCode & "</div>" & vbNewLine
End If
' MsgBox (BannerCollection(i).retImagePath & vbNewLine & BannerCollection(i).imagePath & vbNewLine & BannerCollection(i).bannerTitle & vbNewLine & BannerCollection(i).urlPath)
Next i
CodeString = ""
CodeString = CodeString & "<style type=" & Chr(34) & "text/css" & Chr(34) & ">" & vbNewLine
CodeString = CodeString & "/* Banners */" & vbNewLine
CodeString = CodeString & imgCSS
CodeString = CodeString & "/* Retina Banners */" & vbNewLine
CodeString = CodeString & "#media only screen and (-webkit-min-device-pixel-ratio: 2) {" & vbNewLine
CodeString = CodeString & retinaCSS
CodeString = CodeString & "}" & vbNewLine
CodeString = CodeString & "</style>" & vbNewLine
CodeString = CodeString & "<div id=" & Chr(34) & "sliderTarget" & Chr(34) & " class=" & Chr(34) & "slides" & Chr(34) & ">" & vbNewLine
CodeString = CodeString & firstBannerCode
CodeString = CodeString & "</div>" & vbNewLine
CodeString = CodeString & "<script id=" & Chr(34) & "sliderTemplate" & Chr(34) & " type=" & Chr(34) & "text/template" & Chr(34) & ">" & vbNewLine
CodeString = CodeString & otherBannersCode
CodeString = CodeString & "</script>"
FilePath = Application.DefaultFilePath & "\" & mySheet.Name & "code.txt"
Open FilePath For Output As #2
Print #2, CodeString
Close #2
MsgBox ("code.txt contains:" & CodeString)
MsgBox (Application.DefaultFilePath & "\" & mySheet.Name & "code.txt")
Erase BannerCollection
Next mySheet
End Sub
and here is the Banner type:
Public Type Banner
imagePath As String
retImagePath As String
urlPath As String
bannerTitle As String
End Type
I ended up doing a bit of a code review (oops spent too much time on the Code Review site). I'll post this here in addition to #Jeeped answer in case you get some value from it.
Option Explicit
You should specify Option Explicit at the top of each code module. What this does is tell the VBA compiler to check that every variable that you are trying to use has been declared (i.e. you've got Dim blah as String, Public blah as String or Private blah as String for each blah you're using).
If you attempt to use a variable which hasn't been declared, the compiler will give you a compilation error where the first problem occurs. This helps if you mistype a variable name, otherwise the compiler will think you are talking about something new.
Adding this to the top of your code requires a couple of declarations in your code but nothing major.
Multiple variable declaration on a single line
Don't do it. You have the following line: Dim retinaCSS, imgCSS, firstBannerCode, otherBannersCode, bannerTracking As String which declares 5 variables. The first 4 are declared as variants and the last one is a String. Now your code may work like this but you were probably expecting all 5 to be Strings. Other languages I believe do operate this way but VBA doesn't.
Declare them separately like:
Dim retinaCSS As String
Dim imgCSS As String
Dim firstBannerCode As String
Dim otherBannersCode As String
Dim bannerTracking As String
Don't initialise variables unnecessarily
I see code like:
CodeString = ""
CodeString = CodeString & "<style type=" & Chr(34) & "text/css" & Chr(34) & ">" & vbNewLine
Now the problem with this is that you're assigning the empty string value to CodeString but then you are immediately assigning something else to it in the very next line. The risk is that you might try to use a variable before you have assigned something to it. This isn't a risk for the string type since it implicitly assigned an empty string value when it is created.
You can safely remove the first assignment to it. The danger could come from object references. Say if you have a reference to a worksheet but do not assign a worksheet to the variable before you try to use it. In any case you want to make sure that your variable has the required value before you attempt to use the value it holds.
Use Collection instead of an array
The array code is cumbersome and inflexible. VBA has a simple collection type which allows you to add and remove items to and from it without having to declare a fixed size.
You can also iterate through the contents using a For Each loop.
Here is the code I'm recommending:
Dim BannerCollection As Collection
Set BannerCollection = New Collection
' ...
For Each r In allCells.Rows
Dim thisBanner As Banner
Set thisBanner = New Banner
' ...
BannerCollection.Add thisBanner
Next r
' ...
Dim b As Banner
For Each b In BannerCollection
' do something with the banner.
Next
Now to do this, Banner must be a Class not a Type. I think it makes life a lot easier though.
Split a big method up into single purpose methods.
For instance I extracted a method as follows:
Private Function UrlEncode(ByVal text As String) As String
text = Replace(text, " ", "+")
text = Replace(text, "&", "And")
text = Replace(text, "%", "PC")
text = Replace(text, "!", "")
text = Replace(text, "£", "")
text = Replace(text, ",", "")
text = Replace(text, "'", "")
text = Replace(text, "#", "")
text = Replace(text, ".", "")
UrlEncode = text
End Function
Now this can be referenced like bannerTracking = UrlEncode(b.bannerTitle).
You are setting allCells to a distinct range of cells correctly.
Set allCells = mySheet.Range("a2", mySheet.Cells(lastRow, lastCol))
Then you loop through each row in the allCells range.
For Each r In allCells.Rows
But when you actually go to use r, it is only to use the row number.
thisBanner.imagePath = Cells(r.Row, 2).Value
r.Row is a number between 1 and 1,048,576, nothing more. There is no guarantee that Cells(r.Row, 2).Value refers to something on mySheet; only that whatever worksheet it is coming from it will using whatever worksheet's row number that corresponds to r.row. You need to define some parentage. An With ... End With block within the For ... Next and properly annotated .Range and .Cell references should suffice.
Sub createCode()
Dim myWorkbook As Workbook
Dim mySheet As Worksheet
Dim bannerCount As Integer
Dim BannerCollection() As Banner
Dim r As Range
Dim lastRow, lastCol
Dim allCells As Range
Set myWorkbook = Application.ActiveWorkbook
For Each mySheet In myWorkbook.Worksheets
With mySheet
'declare your vars outside the loop and zero/null then here if necessary.
bannerCount = 0
lastCol = .Range("a2").End(xlToRight).Column
lastRow = .Range("a2").End(xlDown).Row
Set allCells = .Range("a2", .Cells(lastRow, lastCol))
' MsgBox (mySheet.Name)
' MsgBox ("lastRow:" & lastRow & "lastCol:" & lastCol)
ReDim BannerCollection(allCells.Rows.Count)
For Each r In allCells.Rows
Dim thisBanner As Banner
thisBanner.imagePath = ""
thisBanner.retImagePath = ""
thisBanner.bannerTitle = ""
thisBanner.urlPath = ""
bannerCount = bannerCount + 1
' MsgBox (bannerCount)
thisBanner.imagePath = .Cells(r.Row, 2).Value
thisBanner.retImagePath = .Cells(r.Row, 3).Value
thisBanner.bannerTitle = .Cells(r.Row, 4).Value
thisBanner.urlPath = .Cells(r.Row, 5).Value
'MsgBox (.Cells(r.Row, 2).Value)
'MsgBox (.Cells(r.Row, 3).Value)
'MsgBox (.Cells(r.Row, 4).Value)
'MsgBox (.Cells(r.Row, 5).Value)
BannerCollection(bannerCount - 1) = thisBanner
Next r
Dim i As Variant
Dim retinaCSS, imgCSS, firstBannerCode, otherBannersCode, bannerTracking As String
retinaCSS = ""
imgCSS = ""
firstBannerCode = ""
otherBannersCode = ""
bannerTracking = ""
For i = 0 To bannerCount - 1
bannerTracking = BannerCollection(i).bannerTitle
bannerTracking = Replace(bannerTracking, " ", "+")
bannerTracking = Replace(bannerTracking, "&", "And")
bannerTracking = Replace(bannerTracking, "%", "PC")
bannerTracking = Replace(bannerTracking, "!", "")
bannerTracking = Replace(bannerTracking, "£", "")
bannerTracking = Replace(bannerTracking, ",", "")
bannerTracking = Replace(bannerTracking, "'", "")
bannerTracking = Replace(bannerTracking, "#", "")
bannerTracking = Replace(bannerTracking, ".", "")
retinaCSS = retinaCSS & "#sliderTarget .banner-" & i + 1 & "{background-image: url('/assets/static/" & BannerCollection(i).retImagePath & "');}" & vbNewLine
imgCSS = imgCSS & "#sliderTarget .banner-" & i + 1 & "{background-image: url('/assets/static/" & BannerCollection(i).imagePath & "');}" & vbNewLine
If i = 0 Then
firstBannerCode = firstBannerCode & "<div class=" & Chr(34) & "banner banner-" & i + 1 & " staticBanner" & Chr(34) & ">" & vbNewLine
firstBannerCode = firstBannerCode & "" & vbNewLine
firstBannerCode = firstBannerCode & "</div>" & vbNewLine
Else
otherBannersCode = otherBannersCode & "<div class=" & Chr(34) & "banner banner-" & i + 1 & " staticBanner" & Chr(34) & ">" & vbNewLine
otherBannersCode = otherBannersCode & "" & vbNewLine
otherBannersCode = otherBannersCode & "</div>" & vbNewLine
End If
' MsgBox (BannerCollection(i).retImagePath & vbNewLine & BannerCollection(i).imagePath & vbNewLine & BannerCollection(i).bannerTitle & vbNewLine & BannerCollection(i).urlPath)
Next i
CodeString = ""
CodeString = CodeString & "<style type=" & Chr(34) & "text/css" & Chr(34) & ">" & vbNewLine
CodeString = CodeString & "/* Banners */" & vbNewLine
CodeString = CodeString & imgCSS
CodeString = CodeString & "/* Retina Banners */" & vbNewLine
CodeString = CodeString & "#media only screen and (-webkit-min-device-pixel-ratio: 2) {" & vbNewLine
CodeString = CodeString & retinaCSS
CodeString = CodeString & "}" & vbNewLine
CodeString = CodeString & "</style>" & vbNewLine
CodeString = CodeString & "<div id=" & Chr(34) & "sliderTarget" & Chr(34) & " class=" & Chr(34) & "slides" & Chr(34) & ">" & vbNewLine
CodeString = CodeString & firstBannerCode
CodeString = CodeString & "</div>" & vbNewLine
CodeString = CodeString & "<script id=" & Chr(34) & "sliderTemplate" & Chr(34) & " type=" & Chr(34) & "text/template" & Chr(34) & ">" & vbNewLine
CodeString = CodeString & otherBannersCode
CodeString = CodeString & "</script>"
FilePath = Application.DefaultFilePath & "\" & mySheet.Name & "code.txt"
Open FilePath For Output As #2
Print #2, CodeString
Close #2
MsgBox ("code.txt contains:" & CodeString)
MsgBox (Application.DefaultFilePath & "\" & mySheet.Name & "code.txt")
Erase BannerCollection
End With
Next mySheet
End Sub
I have a form with a button, 2 combo boxes as filters, and 3 combo boxes to sort. This button successfully opens a report (trndOTRpt, whose data comes from the query trndOTQry) subject to any criteria that may be chosen and sorted by any sort criteria that may be chosen. I changed the command to instead export the driving query, trndOTQry:
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, _
"trndOTQry", _
"\\es3.com\dfsroot$\YK_Share\office_public\D2S\D2S\D2S_Scorecard\OTTest.xls"
This works successfully. But now I want to apply the same VBA code to filter/sort this query as I did with the report. Here is the whole of it:
(The meat & potatoes is at the bottom, notice the commented out code from the original script to open the report. I simply subbed that for the above TransferSpreadsheet action.)
Private Sub SupervisorsGo_Click()
Dim strWhereCondition As String
Dim strSupervisor As String
Dim strPosition As String
Dim varItem As Variant
For Each varItem In Me.SupervisorCombo.ItemsSelected
strSupervisor = strSupervisor & ",'" & Me.SupervisorCombo.ItemData(varItem) _
& "'"
Next varItem
If Len(strSupervisor) = 0 Then
strSupervisor = "Like '*'"
Else
strSupervisor = Right(strSupervisor, Len(strSupervisor) - 1)
strSupervisor = "IN(" & strSupervisor & ")"
End If
For Each varItem In Me.PositionCombo.ItemsSelected
strPosition = strPosition & ",'" & Me.PositionCombo.ItemData(varItem) _
& "'"
Next varItem
If Len(strPosition) = 0 Then
strPosition = "Like '*'"
Else
strPosition = Right(strPosition, Len(strPosition) - 1)
strPosition = "IN(" & strPosition & ")"
End If
strWhereCondition = "[supervisor] " & strSupervisor & _
" AND [position] " & strPosition
If Me.cboSortOrder1.Value <> "Not Sorted" Then
strSortOrder = "[" & Me.cboSortOrder1.Value & "]"
If Me.cmdSortDirection1.Caption = "Descending" Then
strSortOrder = strSortOrder & " DESC"
End If
If Me.cboSortOrder2.Value <> "Not Sorted" Then
strSortOrder = strSortOrder & ",[" & Me.cboSortOrder2.Value & "]"
If Me.cmdSortDirection2.Caption = "Descending" Then
strSortOrder = strSortOrder & " DESC"
End If
If Me.cboSortOrder3.Value <> "Not Sorted" Then
strSortOrder = strSortOrder & ",[" & Me.cboSortOrder3.Value & "]"
If Me.cmdSortDirection3.Caption = "Descending" Then
strSortOrder = strSortOrder & " DESC"
End If
End If
End If
End If
Debug.Print strWhereCondition
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, _
"trndOTQry", _
"\\es3.com\dfsroot$\YK_Share\office_public\D2S\D2S\D2S_Scorecard\OTTest.xls"
' DoCmd.OpenReport "trndOTRpt", View:=acViewPreview, _
' WhereCondition:=strWhereCondition
With Queries![trndOTQry]
.OrderBy = strSortOrder
.OrderByOn = True
End With
End Sub
This fails. While the original code went With Reports![trndOTRpt], I get Run-time Error 424: Object Required with With Queries![trndOTQry] highlighted. I feel like I have adjusted all references appropriately--why is it not acknowledging the object here?
My goal is to export trndOTQry subject to filters/sorts chosen in the form.