How to handle double quotes in vba - excel

I have a string assigned to variables and need to declare that in cell using vba.
I tried below code and throws error
Dim Var2,Str as string
Var1="OD"
Var2="Leave"
Str="Employee":Var2,"Type":Var1
set ws=ActiveWorkbook.Worksheets("Sheet1")
ws.cells(2,4).value=str
My expected output in cells(2,4) should be "Employee":"Leave","Type":"OD"

My expected output in cells(2,4) should be "Employee":"Leave","Type":"OD"
Store the values in an array. It will be much easier to handle as compared to having so many variables.
You can use Chr(34) for ". Is this what you are trying?
Option Explicit
Sub Sample()
Dim Ar(1 To 4) As String
Dim Strg As String
Dim ws As Worksheet
Ar(1) = "OD"
Ar(2) = "Type"
Ar(3) = "Leave"
Ar(4) = "Employee"
'"Employee":"Leave","Type":"OD"
Strg = Chr(34) & Ar(4) & Chr(34)
Strg = Strg & ":" & Chr(34) & Ar(3) & Chr(34)
Strg = Strg & "," & Chr(34) & Ar(2) & Chr(34)
Strg = Strg & ":" & Chr(34) & Ar(1) & Chr(34)
'Debug.Print Strg
Set ws = ActiveWorkbook.Worksheets("Sheet1")
ws.Cells(2, 4).Value = Strg
End Sub

Related

Generate XML File with VBA

I'm trying to generate an XML file with VBA code.
My goal is to alter Excel data, and then to export this data into a valid XML file. There's only one row of data and one row for the name of the tags which I want to have the data inside.
How can I run through all the data and generate an XML file?
Some sample data (My original file has more columns and data).
(The yellow data is my first block in XML and the green data my second block.)
Here's how the XML File should look:
<?xml version="1.0" encoding="UTF-8"?>
<NmLoader>
<csvBeginTypeDefView handler ="TypeDefinition">
<csvattTemplate>LW</csvattTemplate>
<csvnameSpace>default</csvnameSpace>
<csvname>Tires</csvname>
<csvcontainerDomain/>
<csvtypeParent>Wheels</csvtypeParent>
</csvBeginTypeDefView>
<csvBeginAttributeDefView handler = "AttributeDefinition">
<csvname>TiresAT</csvname>
<csvattDefClass>Definition</csvattDefClass>
<csvdatatype>String</csvdatatype>
<csvIBA>TiresAT</csvIBA>
<csvQoM/>
</csvBeginAttributeDefView>
</NmLoader>
My Code:
Public Sub GenerateXML()
Dim sht As Worksheet
Dim loLetzteZ As Long, loLetzteS As Long, i As Long
Dim rBereich As Range, rng As Range
Dim sTagO As String, sTagC As String, sTagOEnd As String, sTagCStart As String
Dim sZeile As String
Dim strPfad As String
Dim strText As String
sTagO = "<"
sTagOEnd = "/>"
sTagC = ">"
sTagCStart = "</"
Set sht = Worksheets("Data")
'determine the last possible row
loLetzteZ = sht.Cells(Rows.Count, 1).End(xlUp).Row
'determine the last possible column
loLetzteS = sht.Cells(1, Columns.Count).End(xlToLeft).Column
'set me the area for the complete worksheet
Set rBereich = sht.Range("A2:" & Cells(loLetzteZ, loLetzteS).Address)
Application.ScreenUpdating = False
strPfad = ActiveWorkbook.Path & "\Data" & ".xml"
'row for row
For Each rng In rBereich.Rows
With rng
'column for column
For i = 1 To .Columns.Count
'If the tag is empty, then close this
If IsEmpty(.Cells(1, i)) Then
sZeile = sZeile & sTagO & Cells(1, i) & sTagOEnd
Else
'Opening Tag
sZeile = sZeile & sTagO & Cells(1, i) & sTagC
'Data for the tags
sZeile = sZeile & .Cells(1, i)
'End of Tags
sZeile = sZeile & sTagCStart & Cells(1, i) & sTagC
End If
'Write line with distance
sZeile = sZeile & vbCrLf
Next
'Write line with distance
sZeile = sZeile & vbCrLf & vbCrLf
'Open file and write the text
Call InDateiSchreiben(strPfad, sZeile, True)
End With
Next
Application.ScreenUpdating = True
End Sub
Other Solutions I tried:
I've already mapped the XML with Excel, but Excel is not able to export such an XML Schema.
I wrote code in VBA (I'm a beginner) by looking through posts regarding an XML Export.
Try this
Function GetXmlElement(sTagName As String, _
sValue As String, _
Optional bUseEmptyTags As Boolean = False, _
Optional bMultiline As Boolean = False) As String
Dim sStartOpen As String: sStartOpen = "<"
Dim sClose As String: sClose = ">"
Dim sEndOpen As String: sEndOpen = "</"
Dim sEmptyClose As String: sEmptyClose = " />"
Dim sTab As String: sTab = " "
Dim sTagValSeparator As String
Dim sValTagSeparator As String
If bMultiline Then
sTagValSeparator = Chr(10) & sTab
sValTagSeparator = Chr(10)
End If
If Len(sValue) = 0 And bUseEmptyTags Then
GetXmlElement = sStartOpen & sTagName & sEmptyClose
Else
GetXmlElement = sStartOpen & sTagName & sClose & sTagValSeparator & _
Replace(sValue, Chr(10), Chr(10) & sTab) & _
sValTagSeparator
If InStr(1, sTagName, " ") > 0 Then
'tag has attributes'
sTagName = Left(sTagName, InStr(1, sTagName, " ") - 1)
End If
GetXmlElement = GetXmlElement & sEndOpen & sTagName & sClose
End If
End Function
Function GetXMLOutput() As String
Dim lLastCol As Long
Dim i As Long
Dim lCsvBeginCol As Long
Dim sTagName As String
Dim sInnerElements As String
Dim sOutput As String
With ThisWorkbook.Sheets("Data")
lLastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
lCsvBeginCol = 1
For i = 1 To lLastCol
sTagName = .Cells(1, i)
If Left(sTagName, 8) = "csvBegin" And i > lCsvBeginCol Or i = lLastCol Then
' build the outer element
sTagName = .Cells(1, lCsvBeginCol) & "=""" & .Cells(2, lCsvBeginCol) & """"
If Len(sOutput) > 0 Then
sOutput = sOutput & Chr(10) & Chr(10)
End If
sOutput = sOutput & GetXmlElement(sTagName, sInnerElements, True, True)
lCsvBeginCol = i
sInnerElements = ""
ElseIf i <> lCsvBeginCol Then
' build the inner elements
If Len(sInnerElements) > 0 Then sInnerElements = sInnerElements & Chr(10)
sInnerElements = sInnerElements & GetXmlElement(sTagName, .Cells(2, i), True)
End If
Next i
sOutput = GetXmlElement("NmLoader", sOutput, True, True)
sOutput = "<?xml version=""1.0"" encoding=""UTF-8""?>" & Chr(10) & Chr(10) & sOutput
GetXMLOutput = sOutput
Debug.Print sOutput
End With
End Function
Sub GenerateXML()
Dim sFilename As String
sFilename = ThisWorkbook.Path & "\Data.xml"
Open sFilename For Output As #1
Print #1, GetXMLOutput
Close #1
End Sub
Try
Option Explicit
Public Sub GenerateXML()
Dim sht As Worksheet
Set sht = Worksheets("Data")
Dim loLetzteZ As Long, loLetzteS As Long, i As Long
Dim rBereich As Range, rng As Range
Dim sZeile As String
Dim strPfad As String
Dim sTag As String, sTag1 As String, sData As String
'determine the last possible row
loLetzteZ = sht.Cells(Rows.Count, 1).End(xlUp).Row
'determine the last possible column
loLetzteS = sht.Cells(1, Columns.Count).End(xlToLeft).Column
'set me the area for the complete worksheet
Set rBereich = sht.Range("A2:" & Cells(loLetzteZ, loLetzteS).Address)
' output
strPfad = ActiveWorkbook.Path & "\Data" & ".xml"
sTag1 = ""
sZeile = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf _
& "<NmLoader>" & vbCrLf
'row for row
For Each rng In rBereich.Rows
With rng
'column for column
For i = 1 To .Columns.Count
sTag = Trim(sht.Cells(1, i))
sData = Trim(.Cells(1, i))
'If the tag is handler
If LCase(Right(sTag, 7)) = "handler" Then
sTag1 = Split(sTag, " ")(0) ' remove handler
sZeile = sZeile & "<" & sTag1 & " handler=""" & sData & """>"
' is it a closing tag
ElseIf sTag = sTag1 Then
sZeile = sZeile & "</" & sTag1 & ">" & vbCrLf
ElseIf Len(sData) > 0 Then
sZeile = sZeile & vbTab & "<" & sTag & ">" & sData & "</" & sTag & ">"
Else
sZeile = sZeile & vbTab & "<" & sTag & "/>"
End If
sZeile = sZeile & vbCrLf
Next
'Write line with distance
sZeile = sZeile & vbCrLf & "</NmLoader>" & vbCrLf
'Open file and write the text
Debug.Print sZeile
'Call InDateiSchreiben(strPfad, sZeile, True)
End With
Next
MsgBox strPfad & " created", vbInformation
End Sub

Assigning values to an Array for use in a while loop

I am wishing to export data from an Excel sheet to multiple CSV files using an Array, I have written the code that creates the export without issue, but I cannot seem to get my head around assigning the initial values to an Array and then using some kind of while loop from the data in the Array to produce the desired exports.
The unique values I wish to hold in the Array are located in Column A of sheet 1, obviously the values in the column are not unique, but I only wish to reference (add to the Array) once.
Once I have the values in the Array I want to place the code in a while loop to export the data based on the unique value in the Array.
Below in a snippet of my current code, which in isolation works fine;
Public InvDate
Sub ExportAccLinesLoop()
Dim fso, FilePathName, FilePath, Station, StationName, StationDate, Exp, d1, WC, dd, mm, yy
dd = Left(InvDate, 2)
mm = Mid(InvDate, 4, 2)
yy = Right(InvDate, 2)
FilePath = "\\Sunbury-xxx\xxx\Parcels\Attachments\"
FilePathName = FilePath & "Tmp.csv"
Worksheets("Sheet1").Activate
Set rRange = Worksheets("Sheet1").Range("A1", Range("A" & Rows.Count).End(xlUp))
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(FilePath) Then fso.CreateFolder (FilePath) 'create folder if it does not exist
Set inputFile = fso.OpenTextFile(FilePathName, 8, True)
inputFile.WriteLine (Chr(34) & "Rate Acc" & Chr(34) & "," & Chr(34) & "Movement" & Chr(34) & "," & Chr(34) & "Ledger Acc" & Chr(34)) ‘Write Header values
inputFile.Close
For Each rCell In rRange
If rCell.Value = "WAR" Then
RateAcc = rCell(1, 1)
DelCol = rCell(1, 2)
LedgerAcc = rCell(1, 3)
If Not fso.FolderExists(FilePath) Then fso.CreateFolder (FilePath) 'create folder if it does not exist
Set inputFile = fso.OpenTextFile(FilePathName, 8, True)
inputFile.WriteLine (Chr(34) & RateAcc & Chr(34) & "," & Chr(34) & DelCol & Chr(34) & "," & Chr(34) & LedgerAcc & Chr(34)) ‘Write Line values
inputFile.Close
End If 'rCell
Next rCell
fso.CopyFile FilePathName, FilePath & yy & mm & dd & "-" & LedgerAcc & "-" & RateAcc & "-" & "TRAN.csv" 'Copy Tmp.csv to correct filename
fso.DeleteFile FilePathName 'Delete Tmp.csv
End Sub
I assume the while loop will start after Set rRange, indeed the unique Array values will come from the same range, but I'm stuck.
Any ideas?
Dim objDict As Object
Dim key As Variant
Set objDict = CreateObject("System.Collections.ArrayList")
With ThisWorkbook.ActiveSheet
With .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
For Each key In .Value
If Not objDict.Contains(key) Then objDict.Add key
Next
End With
End With

How to fix weird VBA Script error: “Missing ; before statement.”

I am trying to utilize a "dictionary" script that I found to define words in a column. VB throws out that error at me and I am clueless as to how to fix it. AM I using anything that a vba app script could understand? Here is the website that I am using to insert this function into excel: https://script.google.com
Code:
Function DefineWord(wordToDefine As String) As String
' Array to hold the response data.
Dim d() As Byte
Dim r As Research
Dim myDefinition As String
Dim PARSE_PASS_1 As String
Dim PARSE_PASS_2 As String
Dim PARSE_PASS_3 As String
Dim END_OF_DEFINITION As String
'These "constants" are for stripping out just the definitions from the JSON data
PARSE_PASS_1 = Chr(34) & "webDefinitions" & Chr(34) & ":"
PARSE_PASS_2 = Chr(34) & "entries" & Chr(34) & ":"
PARSE_PASS_3 = "{" & Chr(34) & "type" & Chr(34) & ":" & Chr(34) & "text" & Chr(34) & "," & Chr(34) & "text" & Chr(34) & ":"
END_OF_DEFINITION = "," & Chr(34) & "language" & Chr(34) & ":" & Chr(34) & "en" & Chr(34) & "}"
Const SPLIT_DELIMITER = "|"
' Assemble an HTTP Request.
Dim url As String
Dim WinHttpReq As Variant
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
'Get the definition from Google's online dictionary:
url = "http://www.google.com/dictionary/json?callback=dict_api.callbacks.id100&q=" & wordToDefine & "&sl=en&tl=en&restrict=pr%2Cde&client=te"
WinHttpReq.Open "GET", url, False
' Send the HTTP Request.
WinHttpReq.Send
'Print status to the immediate window
Debug.Print WinHttpReq.Status & " - " & WinHttpReq.StatusText
'Get the defintion
myDefinition = StrConv(WinHttpReq.ResponseBody, vbUnicode)
'Get to the meat of the definition
myDefinition = Mid$(myDefinition, InStr(1, myDefinition, PARSE_PASS_1, vbTextCompare))
myDefinition = Mid$(myDefinition, InStr(1, myDefinition, PARSE_PASS_2, vbTextCompare))
myDefinition = Replace(myDefinition, PARSE_PASS_3, SPLIT_DELIMITER)
'Split what's left of the string into an array
Dim definitionArray As Variant
definitionArray = Split(myDefinition, SPLIT_DELIMITER)
Dim temp As String
Dim newDefinition As String
Dim iCount As Integer
'Loop through the array, remove unwanted characters and create a single string containing all the definitions
For iCount = 1 To UBound(definitionArray) 'item 0 will not contain the definition
temp = definitionArray(iCount)
temp = Replace(temp, END_OF_DEFINITION, SPLIT_DELIMITER)
temp = Replace(temp, "\x22", "")
temp = Replace(temp, "\x27", "")
temp = Replace(temp, Chr$(34), "")
temp = iCount & ". " & Trim(temp)
newDefinition = newDefinition & Mid$(temp, 1, InStr(1, temp, SPLIT_DELIMITER) - 1) & vbLf 'Hmmmm....vbLf doesn't put a carriage return in the cell. Not sure what the deal is there.
Next iCount
'Put list of definitions in the Immeidate window
Debug.Print newDefinition
'Return the value
DefineWord = newDefinition
End Function
This looks like visual basic, Google uses Apps script which is essentially javascipt. In Javascript you terminate statements with semicolon, that's what it's looking for.
link here:Google Help Forum

copy sheet to text file with specific template skips even numbers

I want to copy sheet to text file with specific template, I defined a range but the problem is it skips even numbers it means rows A2, A4,A6... not copied
so it brings at the end of the result empty rows
Option Explicit
Sub txtFile()
Dim strPath As String
Dim fso As Object
Dim ts As Object
Dim wsDest As Worksheet
Set wsDest = Sheets("Filter FS")
wsDest.Select
Set fso = CreateObject("Scripting.FileSystemObject")
Dim cellAimsID As Variant
Dim cellAmount As Variant
Dim cellCurrencyISO As Variant
Dim cellReason As Variant
Dim cellExpiryDate As Variant
Dim FirstRow As String
Dim LastRow As String
Dim a As Range, b As Range, cell As String, rng As Range
Set a = Selection
Set ts = fso.CreateTextFile("C:\Users\cben\Documents\BKC\FinancialSecurity\test13.txt", True, True)
' for each cell in the worksheet create a line in text fil
FirstRow = wsDest.UsedRange.Rows(1).Row
LastRow = wsDest.Range("A" & Rows.Count).End(xlUp).Row
Set rng = wsDest.Range("A2:A" & LastRow)
'Set rng = wsDest.Range("A1:A5")
For Each a In rng
cellAimsID = a.Cells(a.Row, 1)
cellAmount = a.Cells(a.Row, 2)
cellCurrencyISO = a.Cells(a.Row, 3)
cellReason = a.Cells(a.Row, 4)
cellExpiryDate = a.Cells(a.Row, 5)
'AimsID, Amount, Currency, Reason, ExpiryDate are the name of columns in worksheet
ts.WriteLine (Chr(9) & "cases" & ": [")
ts.WriteLine (Chr(9) & "{")
ts.WriteLine (Chr(9) & "AimsID:" & cellAimsID & ",")
ts.WriteLine (Chr(9) & "Amount:" & cellAmount & ",")
ts.WriteLine (Chr(9) & "CurrencyISO:" & cellCurrencyISO & ",")
ts.WriteLine (Chr(9) & "Reason:" & cellReason & ",")
ts.WriteLine (Chr(9) & "ExpiryDate:" & cellExpiryDate & ",")
ts.WriteLine (Chr(9) & "}" & ",")
Next
ts.Close
End Sub
here is the result
for exemple AimsID= 69210794 correspond to A41 next AimsID =86917526 corresponds to A43 not A42 in the result
The problem lies in your For Each loop as detailed below.
For Each a In rng
cellAimsID = a.Cells(a.Row, 1)
cellAmount = a.Cells(a.Row, 2)
cellCurrencyISO = a.Cells(a.Row, 3)
cellReason = a.Cells(a.Row, 4)
cellExpiryDate = a.Cells(a.Row, 5)
In this loop, the variable a refers to a Range object. Yet, inside of the loop, you assign to each variable a Range property of a Range object. Let's take a closer look as an example:
`cellAimsID = a.Cells(a.Row, 1)
Let's assume you are on the second iteration of the loop, and the variable a refers to cell A3. The syntax above says cellsAimsID = Range("A3").Range("A3"). What happens when we apply a Range property to a Range object? It basically offsets cell. In that above example, the cell pointer essentially moves to a cell that would be the third cell in Column A IF the range started with A3.
I know that sounds a bit confusing, but follow up if you have questions.
To fix the error, replace the syntax with (notice I removed the a qualifier):
cellAimsID = Cells(a.Row, 1)
cellAimsID = Cells(a.Row, 1)
As a side note, it is a good practice to fully qualify your ranges with a sheet name in case your macro ever does processing on different sheets. So it would be even better to change the code to:
cellAimsID = wsDest.Cells(a.Row, 1)
cellAimsID = wsDest.Cells(a.Row, 1)
This is my code after changes,
It allows the export of a worksheet in text file with specific template.
PS : Last line have a close Array so I did it outside the range.
Option Explicit
Sub txtFile()
Dim strPath As String
Dim fso As Object
Dim ts As Object
Dim wsDest As Worksheet
Set wsDest = Sheets("Filter FS")
wsDest.Select
Set fso = CreateObject("Scripting.FileSystemObject")
Dim cellAimsID As Variant
Dim cellAmount As Variant
Dim cellCurrencyISO As Variant
Dim cellReason As Variant
Dim cellExpiryDate As Variant
Dim FirstRow As String
Dim LastRow As String
Dim LastRowB As String
Dim a As Range, b As Range, cell As String, rng As Range, Lastrng As Range
Set a = Selection
Set ts = fso.CreateTextFile("C:\Users\cben\Documents\BKC\FinancialSecurity\test20.txt", True, True)
' for each cell in the worksheet create a line in text fil
FirstRow = wsDest.UsedRange.Rows(1).Row
LastRow = wsDest.Range("A" & Rows.Count).End(xlUp).Row
LastRowB = (wsDest.Range("A" & Rows.Count).End(xlUp).Row) - 1
Set rng = wsDest.Range("A2:A" & LastRowB)
Set Lastrng = wsDest.Range("A" & LastRow)
ts.WriteLine ("{")
ts.WriteLine (Chr(9) & "“cases”" & ": [")
For Each a In rng
cellAimsID = Cells(a.Row, 1)
cellCurrencyISO = Cells(a.Row, 2)
cellAmount = Cells(a.Row, 3)
cellReason = Cells(a.Row, 4)
cellExpiryDate = Cells(a.Row, 5)
'AimsID, Amount, Currency, Reason, ExpiryDate are the name of columns in worksheet
ts.WriteLine (Chr(9) & "{")
ts.WriteLine (Chr(9) & "“AimsID”" & ":" & Chr(9) & cellAimsID & ",")
ts.WriteLine (Chr(9) & "“Amount”" & ":" & Chr(9) & cellAmount & ",")
ts.WriteLine (Chr(9) & "“CurrencyISO”" & ":" & Chr(9) & cellCurrencyISO & ",")
ts.WriteLine (Chr(9) & "“Reason”" & ":" & Chr(9) & cellReason & ",")
ts.WriteLine (Chr(9) & "“ExpiryDate”" & ":" & Chr(9) & "“" & cellExpiryDate & "”")
ts.WriteLine (Chr(9) & "}" & ",")
Next
cellAimsID = Cells(LastRow, 1)
cellCurrencyISO = Cells(LastRow, 2)
cellAmount = Cells(LastRow, 3)
cellReason = Cells(LastRow, 4)
cellExpiryDate = Cells(LastRow, 5)
ts.WriteLine (Chr(9) & "{")
ts.WriteLine (Chr(9) & "“AimsID”" & ":" & Chr(9) & cellAimsID & ",")
ts.WriteLine (Chr(9) & "“Amount”" & ":" & Chr(9) & cellAmount & ",")
ts.WriteLine (Chr(9) & "“CurrencyISO”" & ":" & Chr(9) & cellCurrencyISO & ",")
ts.WriteLine (Chr(9) & "“Reason”" & ":" & Chr(9) & cellReason & ",")
ts.WriteLine (Chr(9) & "“ExpiryDate”" & ":" & Chr(9) & "“" & cellExpiryDate & "”")
ts.WriteLine (Chr(9) & "}" & "]")
ts.WriteLine ("}")
ts.Close
End Sub

Repeated 1 mail while sending mail via Thunderbird from Excel

I have created VBA code for sending mails with different attachments to different addresses, via Thunderbird. The code looks correct but while creating particular mail bodies it uses still the first values. And the strange fact is that in the debugging window all looks correct and the values are changing.
$
Option Explicit
Sub SendMailThunder_Click()
Dim strEmpfaenger1 As String
Dim strBetr As String
Dim strBody As String
Dim strFile2 As Variant
Dim strTh As String
Dim strCommand As Variant
Dim Nazev As String
Dim vysledek As Variant
Dim Seznam As Excel.Worksheet
Dim PS As Integer
Dim y As Long
Set Seznam = ThisWorkbook.Worksheets("Ridici")
' number of items in the column
PS = Seznam.Cells(Rows.Count, 11).End(xlUp).Row
With Seznam
For y = 4 To PS
' Name of attachment
Nazev = .Cells(y, 12).Value
' selected email
strEmpfaenger1 = .Cells(y, 15).Value
strBetr = .Range("O1")
strBody = .Range("O2")
strTh = "C:\Users\alois.konecny\AppData\Local\Mozilla Thunderbird\thunderbird.exe"
' path to attachment
cesta = .Range("N1")
' attachment including path
priloha = "\" & Nazev & ".xls"
vysledek = cesta & priloha
strFile2 = vysledek
strCommand = strCommand & " -compose " & "to=" & Chr(34) & strEmpfaenger1 & Chr(34)
strCommand = strCommand & ",subject=" & Chr(34) & strBetr & Chr(34)
strCommand = strCommand & ",body=" & Chr(34) & strBody & Chr(34)
strCommand = strCommand & ",attachment=" & "file:///" & Replace(strFile2, "\", "/")
Shell strTh & strCommand, vbNormalFocus
Next y
End With
End Sub
$
The code is a bit hard to read, but have your tried this:
file://
instead of
file:///

Resources