Extract Columns from Excel Files then Append to .CSV file

Hi Everyone,

I hope this is not too much, but I badly need help on creating a VBScript for Excel that can:
1. Check if any excel file exists, if there are, open them one by one and do step 2 onwards; if none, do nothing.
2. Copy cells F8:Z8 of Sheet 1 all the way to the bottom where F8 is not null and Paste it to C1 to a new excel file.
3. Then copy the value from A2 and B2 then paste/reiterate it to A1 and B1 all the way to the bottom where F8 is not null of the new excel file.
4. Save the result to .csv.
5. Append all .csv results into one (there are multiple excel source files).

Here’s an illustration:

 

Sounds not that complicated to me.

Code:

Const strCsv = "test.csv"
Const srtSeparator = ";"

Const ForWriting = 2
Const ForAppending = 8
usedMode = ForWriting

Dim arrLine(22)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objCSV = objFSO.OpenTextFile(strCsv, usedMode, True)
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))

For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(1)
    Set objCell = objWS.Cells(8, 6)
    If objCell.Text <> "" Then
      arrLine(0) = objWS.Cells(2, 1)
      arrLine(1) = objWS.Cells(2, 2)
      line = 0
      Do
        For i = 0 To 20
          arrLine(i + 2) = objCell.Offset(line, i).Text
        Next
        objCSV.WriteLine Join(arrLine, srtSeparator)
        If objCell.Offset(line + 1, 0).Text = "" Then Exit Do
        line = line + 1
      Loop
    End If
    Set objCell = Nothing
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next

objXL.Quit
Set objXL = Nothing
objCSV.Close
Set objCSV = Nothing

MsgBox "Process Finished.", vbInformation, "Done"

Some notes:
- You wrote "where F8 is not null". My interpretation is "where F8 is not empty". I hope that's not a misunderstanding.

- The script is searching for xls files in the current directory.

- strCsv is the name of your csv file.

- srtSeparator is the data separator in your csv file. For my german settings it's a semi colon. Since csv means Comma Separated Values you should change it to a comma if semi colon doesn't work for you.

- usedMode:
* ForWriting means that each time the script runs the csv file is overwritten (or new created)
* ForAppending means that each time the script runs the new data are appended to the existing csv file
Choose tho mode you would prefer.

- Make sure that none of the xls files are opened if you run the script.

- The script displayes a message if all xls files are processed.

Hope that helps.

Regards
GermanOne

 

Thank you so much GermanOne. Your code did the job!

Here are my responses to your notes:

- Correct, that’s exactly what I meant.

- Yes, this exactly what I need.

- I’ll change it to comma. Comma separators are most common here.

- Thanks! This is so cool! This will come in handy.

Thanks Man, you're the best!

 

Hi GermanOne,

You are really great and I can't thank you enough for helping me out. But before we close this topic, there's more thing I really hope would not be much of a trouble to you.

From the code you made, there are some tweaking I need from you to be able to perform pivoting/normalization from the output of your code.

• In the source XLS file, cells from G2, H2, I2,...Z2 (columns with content varies, but limit is Z2) have code columns.
• These codes should be converted to a single column (pivot/normalize) and be pasted/reiterated at column D in the CSV target file as long as “when F8 is not empty” with its corresponding values beside it untill all code columns have been processed.

Here's an Illustration:

 

Just to make sure:
There is only one source file you wanna process this way or again for each xls file in a folder? If so, should the data be outputted into a single csv file or one csv file for each xls?

Regards
GermanOne

 

Hi GermanOne,

• Please process this way for each xls file in a folder. There are many .xls files.
  
• Kindly output this to a single .csv file appending the records from all .xls files in a folder.

Thank you so much for this! I owe you a lot man.

 

Hi r0mmel,

hope this will work as expected:

Code:

Const strCsv = "test.csv"
Const srtSeparator = ","

Const ForWriting = 2
Const ForAppending = 8
usedMode = ForWriting

Dim arrLine(4)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objCSV = objFSO.OpenTextFile(strCsv, usedMode, True)
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))
For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(1)
    If objWS.Cells(8, 6).Text <> "" Then
      process_content
    End If
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next
objXL.Quit
Set objXL = Nothing
objCSV.Close
Set objCSV = Nothing
MsgBox "Process Finished.", vbInformation, "Done"


Sub process_content()
    arrLine(0) = objWS.Cells(2, 1).Text
    arrLine(1) = objWS.Cells(2, 2).Text
    line = 0
    column = 0
    Set objCell = objWS.Cells(8, 6)
    Do
      ReDim Preserve arrY(line)
      arrY(line) = objCell.Offset(line, 0).Text
      If objCell.Offset(line, 0).Text = "" Then Exit Do
      line = line + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(2, 7)
    Do
      ReDim Preserve arrX(column)
      arrX(column) = objCell.Offset(0, column).Text
      If objCell.Offset(0, column).Text = "" Then Exit Do
      column = column + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(8, 7)
    For x = 0 To column - 1
      For y = 0 To line - 1
        arrLine(2) = arrY(y)
        arrLine(3) = arrX(x)
        arrLine(4) = objCell.Offset(x, y).Text
        objCSV.WriteLine Join(arrLine, srtSeparator)
      Next
    Next
    Set objCell = Nothing
End Sub

Regards
GermanOne

 

Argh, sorry I mistaked x for y.
Use this code instead. I also made some minor optimizings.

Code:

Const strCsv = "test.csv"
Const srtSeparator = ";"

Const ForWriting = 2
Const ForAppending = 8
usedMode = ForWriting

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objCSV = objFSO.OpenTextFile(strCsv, usedMode, True)
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))
For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(1)
    If objWS.Cells(8, 6).Text <> "" Then
      process_content
    End If
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next
objXL.Quit
Set objXL = Nothing
objCSV.Close
Set objCSV = Nothing
MsgBox "Process Finished.", vbInformation, "Done"


Sub process_content()
    Dim arrLine(4), arrX(), arrY()
    arrLine(0) = objWS.Cells(2, 1).Text
    arrLine(1) = objWS.Cells(2, 2).Text
    line = 0
    column = 0
    Set objCell = objWS.Cells(8, 6)
    Do
      Redim Preserve arrY(line)
      arrY(line) = objCell.Offset(line, 0).Text
      If objCell.Offset(line + 1, 0).Text = "" Then Exit Do
      line = line + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(2, 7)
    Do
      Redim Preserve arrX(column)
      arrX(column) = objCell.Offset(0, column).Text
      If objCell.Offset(0, column + 1).Text = "" Then Exit Do
      column = column + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(8, 7)
    For x = 0 To column
      For y = 0 To line
        arrLine(2) = arrY(y)
        arrLine(3) = arrX(x)
        arrLine(4) = objCell.Offset(y, x).Text
        objCSV.WriteLine Join(arrLine, srtSeparator)
      Next
    Next
    Set objCell = Nothing
End Sub

Regards
GermanOne

 

This is exactly what I need. A million thanks GermanOne! You're the best!

 

Hi GermanOne,

In the 4th line of your Sub process_content():

"arrLine(1) = objWS.Cells(2, 2).Text"

- The value in this field is sometimes text, and sometimes, numbers.



For the text values, this works fine. But when the value is numeric (ex: 910140) it cannot be fetched.

Is there a way for you to enable it to handle numeric values as well?

 

Sorry, let me rephrase my question:

Is there a way for you to convert all the encountered numeric values to text?

(example: converting 910140 to string so it can also be fetched by "arrLine(1) = objWS.Cells(2, 2).Text".

 

Haha I see your problem. OK, let me explain. As you can see I save each cell-content using ".Text". That means everything is saved as displayed on screen. Open the CSV file with a text editor and you will see it's true.
But now, if you open the file with Excel, Excel itself tries to find out which data type is saved. For that reason it converts e.g. 0815 to the numeric value 815 and (afaik) there is no chance to do something against it. CSV is a text file with values, separators and line breaks, it does not contain any formatting informations.

Regards
GermanOne

 

Alright, now i get it. Thanks GermanOne. I figured that I can just fix that from the excel file itself with TEXT() function.

 

Hi GermanOne,

Your codes have been very useful to me. Even the very first one you created (version1).

Going back to the first code you created, I'm trying to reuse it on another sheet of the same file (2nd sheet) but I'm getting errors when I tried modifying it. Here's what I'm trying to do:



This is basically almost the same with the first one you made. Just with different columns this time and that it's on the 2nd sheet.


And here's your code that I'm trying to edit. Notice that I changed the Set objWS = objWB.Worksheets() to 2:

Code:

Const strCsv = "TWN_VF_SD.csv"
Const srtSeparator = ","

Const ForWriting = 2
Const ForAppending = 8
usedMode = ForWriting

Dim arrLine(22)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objCSV = objFSO.OpenTextFile(strCsv, usedMode, True)
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))

For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(2)
    Set objCell = objWS.Cells(9, 4)
    If objCell.Text <> "" Then
      arrLine(0) = objWS.Cells(2, 1)
      arrLine(1) = objWS.Cells(2, 2)
      line = 0
      Do
        For i = 0 To 4
          arrLine(i + 2) = objCell.Offset(line, i).Text
        Next
        objCSV.WriteLine Join(arrLine, srtSeparator)
        If objCell.Offset(line + 1, 0).Text = "" Then Exit Do
        line = line + 1
      Loop
    End If
    Set objCell = Nothing
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next

objXL.Quit
Set objXL = Nothing
objCSV.Close
Set objCSV = Nothing

MsgBox "Process Finished.", vbInformation, "Done"

 

Try that code:

Code:

Const strCsv = "TWN_VF_SD.csv"
Const srtSeparator = ","

Const ForWriting = 2
Const ForAppending = 8
usedMode = ForWriting

Dim arrLine(6)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objCSV = objFSO.OpenTextFile(strCsv, usedMode, True)
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))

For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(2)
    Set objCell = objWS.Cells(8, 4)
    If objCell.Text <> "" Then
      arrLine(0) = objWS.Cells(2, 1).Text
      arrLine(1) = objWS.Cells(2, 2).Text
      line = 0
      Do
        arrLine(2) = objCell.Offset(line, 0).Text
        arrLine(3) = objCell.Offset(line, 2).Text
        arrLine(4) = objCell.Offset(line, 3).Text
        arrLine(5) = objCell.Offset(line, 4).Text
        arrLine(6) = objCell.Offset(line, 5).Text
        objCSV.WriteLine Join(arrLine, srtSeparator)
        If objCell.Offset(line + 1, 0).Text = "" Then Exit Do
        line = line + 1
      Loop
    End If
    Set objCell = Nothing
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next

objXL.Quit
Set objXL = Nothing
objCSV.Close
Set objCSV = Nothing

MsgBox "Process Finished.", vbInformation, "Done"

For your understanding:
- objWS.Cells(2, 1)
Cells refers to an absolute position where the first number is the row and the second number is the column. So Cells(2, 1) is the 2nd row and the first column = A2

- objCell.Offset(0, 2)
Offset refers to an relative position. Starting point is the cell that "objCell" refers to.
If objCell is Cells(8, 4) = D8 then objCell.Offset(0, 2) refers to the cell in the same line (8 + 0) and two columns to the right (4 + 2).
= Cells(8, 6) = F8

Regards
GermanOne

 

A Million thanks GermanOne! so that's why my edit was not working. Anyway, you've been a great help and I appreciate you taking your time helping people around. Kudos to you!

You saved the day! As always

 

Hi GermanOne,

Sorry to bother you again. I've been trying my best to revise/edit your scripts but I still keep on getting an error.

I'm trying to add a new column (to be inserted on the 3rd column of the output) using your code:

Code:

Const strCsv = "TWN_VF_SDI.csv"
Const srtSeparator = ","

Const ForWriting = 2
Const ForAppending = 8
usedMode = ForWriting

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objCSV = objFSO.OpenTextFile(strCsv, usedMode, True)
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))
For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(1)
    If objWS.Cells(8, 6).Text <> "" Then
      process_content
    End If
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next
objXL.Quit
Set objXL = Nothing
objCSV.Close
Set objCSV = Nothing
MsgBox "Process finished for SDI Visit Forms. Check TWN_VF_SDI.csv file.", vbInformation, "Done"


Sub process_content()
    Dim arrLine(5), arrX(), arrY()
    arrLine(0) = objWS.Cells(5, 5).Text
    arrLine(1) = objWS.Cells(2, 2).Text
    arrLine(2) = objWS.Cells(6, 5).Text
    line = 0
    column = 0
    Set objCell = objWS.Cells(8, 6)
    Do
      Redim Preserve arrY(line)
      arrY(line) = objCell.Offset(line, 0).Text
      If objCell.Offset(line + 1, 0).Text = "" Then Exit Do
      line = line + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(2, 7)
    Do
      Redim Preserve arrX(column)
      arrX(column) = objCell.Offset(0, column).Text
      If objCell.Offset(0, column + 1).Text = "" Then Exit Do
      column = column + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(8, 7)
    For x = 0 To column
      For y = 0 To line
        arrLine(3) = arrY(y)
        arrLine(4) = arrX(x)
        arrLine(5) = objCell.Offset(y, x).Text
        objCSV.WriteLine Join(arrLine, srtSeparator)
      Next
    Next
    Set objCell = Nothing
End Sub

notice the part where I put "arrLine(2) = objWS.Cells(6, 5).Text"? that's the new repeating column I'm trying to add. I observed the arrLine count and added 1 to it and changed the numbering but there's still an error pointing to the "objCSV.WriteLine Join(arrLine, srtSeparator)" part.

What am I missing here?

Thanks GermanOne,
Rommel

 

Hi r0mmel,

your code works fine for Excel files like in post #4. I added values in cell E5 and E6 which you need for repeating in column A and C of your csv file (according to your code). I cannot find an error :confused

Regards
GermanOne

 

Hi GermanOne,

I figured out why there's an error occuring when I try to capture the value in Cell(6,5) its because the cell's content is in another language and my guess is that the script allows only letters and/or numbers for it to work because i tried replacing it with an English word and it stopped showing the error.

Thanks anyway, my apologies for not trying enough before I ask you.

Thanks man,
r0mmel

 

Well, sometimes it's better to ask and obtain a 2nd opinion to find out why the code failed. No harm done

Probably it's possible to get it run by reading and writing all cell contents in unicode (little endian). But in this case we have to prepend a BOM (Byte Order Mark) and we have to use a combination of TAB and NUL characters instead of comma. To be honest, I would avoid that if possible. I have only a diffuse notion how to implement it. Probably I would need an ADODB Recordset for buffering or something similar ...

Regards
GermanOne

 

Yeah, I totally agree. I'll think of another workaround for this. Thanks for your ideas GermanOne. Being able to process foreign language in excel takes a lot of complicated steps. Anyway, you've been a great help man. Thanks a lot. You're the best!

Regards,
Rommel

 

I had a look at the MSDN. Finally the ADO stuff is easier than I was afraid.
I changed your latest code:

Code:

Const strCsv = "TWN_VF_SDI.csv"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))

Set objADOS = CreateObject("ADODB.Stream")
objADOS.Type = 2
objADOS.Open

For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(1)
    If objWS.Cells(8, 6).Text <> "" Then
      process_content
    End If
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next

objADOS.Position = 0
objADOS.Charset = "UTF-16"
objADOS.SaveToFile strCsv, 2
objADOS.Close

objXL.Quit
Set objXL = Nothing
MsgBox "Process finished for SDI Visit Forms. Check TWN_VF_SDI.csv file.", vbInformation, "Done"

'-----------------------------------------------------------------------------------------------'
Sub process_content()
    Dim arrLine(2), arrX(), arrY()
    arrLine(0) = objWS.Cells(5, 5).Text
    arrLine(1) = objWS.Cells(2, 2).Text
    arrLine(2) = objWS.Cells(6, 5).Text
    line = 0
    column = 0
    Set objCell = objWS.Cells(8, 6)
    Do
      Redim Preserve arrY(line)
      arrY(line) = objCell.Offset(line, 0).Text
      If objCell.Offset(line + 1, 0).Text = "" Then Exit Do
      line = line + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(2, 7)
    Do
      Redim Preserve arrX(column)
      arrX(column) = objCell.Offset(0, column).Text
      If objCell.Offset(0, column + 1).Text = "" Then Exit Do
      column = column + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(8, 7)
    For x = 0 To column
      For y = 0 To line

        objADOS.WriteText arrLine(0) & vbTab & arrLine(1) & vbTab & arrLine(2) & vbTab  & _
          arrY(y) & vbTab & arrX(x) & vbTab & objCell.Offset(y, x).Text & vbCrLf

      Next
    Next
    Set objCell = Nothing
End Sub

That worked for me (tested with some Chinese signs).

Regards
GermanOne

 

Man, you never stop amazing me, GermanOne. Your code did it! Thank you so much!

I have one last favor to ask. Can you please do the ADO thing on this code also?

Code:

Const strCsv = "TWN_VF_SD.csv"
Const srtSeparator = ","

Const ForWriting = 2
Const ForAppending = 8
usedMode = ForWriting

Dim arrLine(7)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objCSV = objFSO.OpenTextFile(strCsv, usedMode, True)
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))

For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(2)
    Set objCell = objWS.Cells(8, 4)
    If objCell.Text <> "" Then
      arrLine(0) = objWS.Cells(5, 6).Text
      arrLine(1) = objWS.Cells(2, 2).Text
	  arrLine(2) = objWS.Cells(6, 6).Text
	  
      line = 0
      Do
        arrLine(3) = objCell.Offset(line, 0).Text
        arrLine(4) = objCell.Offset(line, 2).Text
        arrLine(5) = objCell.Offset(line, 3).Text
        arrLine(6) = objCell.Offset(line, 4).Text
        arrLine(7) = objCell.Offset(line, 5).Text
        objCSV.WriteLine Join(arrLine, srtSeparator)
        If objCell.Offset(line + 1, 0).Text = "" Then Exit Do
        line = line + 1
      Loop
    End If
    Set objCell = Nothing
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next

objXL.Quit
Set objXL = Nothing
objCSV.Close
Set objCSV = Nothing

MsgBox "Process finished for SD Visit Forms. Check TWN_VF_SD.csv file.", vbInformation, "Done"

 

Hi r0mmel,

it's not a big deal I guess.
Untested:

Code:

Const strCsv = "TWN_VF_SD.csv"

Dim arrLine(2)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))

Set objADOS = CreateObject("ADODB.Stream")
objADOS.Type = 2
objADOS.Open
objADOS.Charset = "UTF-16"

For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(2)
    Set objCell = objWS.Cells(8, 4)
    If objCell.Text <> "" Then
      arrLine(0) = objWS.Cells(5, 6).Text
      arrLine(1) = objWS.Cells(2, 2).Text
      arrLine(2) = objWS.Cells(6, 6).Text

      line = 0
      Do
        objADOS.WriteText arrLine(0) & vbTab & arrLine(1) & vbTab & arrLine(2) & vbTab & _
           objCell.Offset(line, 0).Text & vbTab & objCell.Offset(line, 2).Text & vbTab & _
           objCell.Offset(line, 3).Text & vbTab & objCell.Offset(line, 4).Text & vbTab & _
           objCell.Offset(line, 5).Text & vbCrLf

        If objCell.Offset(line + 1, 0).Text = "" Then Exit Do
        line = line + 1
      Loop
    End If
    Set objCell = Nothing
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next

objADOS.Position = 0
objADOS.SaveToFile strCsv, 2
objADOS.Close

objXL.Quit
Set objXL = Nothing

MsgBox "Process finished for SD Visit Forms. Check TWN_VF_SD.csv file.", vbInformation, "Done"

Regards
GermanOne

 

It is to me. Thanks GermanOne! As always, your vbscript worked!

 

Hi GermanOne,

I did not notice that your new ADO vbscripts are now tab delimited. Unfortunately, I really need those outputs to be comma delimited. I tried converting it back to comma delimited using [Const srtSeparator = ","] and replacing the [vbTabs] with it but when I open the .csv file in excel, it does not spread into the columns and occupy column A only.

Here are the two VBScripts, hope you could help me figure out why there's something wrong with my attempt at converting these to comma delimited:

VBScript 1:

Code:

Const strCsv = "TWN_VF_SDI.csv"
Const srtSeparator = ","

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))

Set objADOS = CreateObject("ADODB.Stream")
objADOS.Type = 2
objADOS.Open

For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(1)
    If objWS.Cells(8, 6).Text <> "" Then
      process_content
    End If
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next

objADOS.Position = 0
objADOS.Charset = "UTF-16"
objADOS.SaveToFile strCsv, 2
objADOS.Close

objXL.Quit
Set objXL = Nothing
MsgBox "Process finished for SDI Visit Forms. Check TWN_VF_SDI.csv file.", vbInformation, "Done"

'-----------------------------------------------------------------------------------------------'
Sub process_content()
    Dim arrLine(2), arrX(), arrY()
    arrLine(0) = objWS.Cells(5, 5).Text
    arrLine(1) = objWS.Cells(2, 2).Text
    arrLine(2) = objFile.Name
    line = 0
    column = 0
    Set objCell = objWS.Cells(8, 6)
    Do
      Redim Preserve arrY(line)
      arrY(line) = objCell.Offset(line, 0).Text
      If objCell.Offset(line + 1, 0).Text = "" Then Exit Do
      line = line + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(2, 7)
    Do
      Redim Preserve arrX(column)
      arrX(column) = objCell.Offset(0, column).Text
      If objCell.Offset(0, column + 1).Text = "" Then Exit Do
      column = column + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(8, 7)
    For x = 0 To column
      For y = 0 To line

        objADOS.WriteText arrLine(0) & srtSeparator & arrLine(1) & srtSeparator & arrLine(2) & srtSeparator  & _
          arrY(y) & srtSeparator & arrX(x) & srtSeparator & objCell.Offset(y, x).Text & vbCrLf

      Next
    Next
    Set objCell = Nothing
End Sub

VBScript 2:

Code:

Const strCsv = "TWN_VF_SD.csv"
Const srtSeparator = ","

Dim arrLine(2)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))

Set objADOS = CreateObject("ADODB.Stream")
objADOS.Type = 2
objADOS.Open
objADOS.Charset = "UTF-16"

For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(2)
    Set objCell = objWS.Cells(8, 4)
    If objCell.Text <> "" Then
      arrLine(0) = objWS.Cells(5, 6).Text
      arrLine(1) = objWS.Cells(2, 2).Text
      arrLine(2) = objFile.Name

      line = 0
      Do
        objADOS.WriteText arrLine(0) & srtSeparator & arrLine(1) & srtSeparator & arrLine(2) & srtSeparator & _
           objCell.Offset(line, 0).Text & srtSeparator & objCell.Offset(line, 2).Text & srtSeparator & _
           objCell.Offset(line, 3).Text & srtSeparator & objCell.Offset(line, 4).Text & srtSeparator & _
           objCell.Offset(line, 5).Text & vbCrLf

        If objCell.Offset(line + 1, 0).Text = "" Then Exit Do
        line = line + 1
      Loop
    End If
    Set objCell = Nothing
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next

objADOS.Position = 0
objADOS.SaveToFile strCsv, 2
objADOS.Close

objXL.Quit
Set objXL = Nothing

MsgBox "Process finished for SD Visit Forms. Check TWN_VF_SD.csv file.", vbInformation, "Done"

 

Well, in a UTF-16 encoded document you need 16 Bit for each character. For that reason a comma seems not to be a comma but a comma and a NUL character. Open the csv file in a HEX Editor to see what I try to tell you.
How ever, obviously this combination of comma and NUL can't be parsed by Excel as a separator. For that reason I used the TAB which works for UTF-16.

To make it work with commas you have to switch to UTF-8. Now the 16 Bit are only used for characters where 8 Bit are not enough for representing.
NOTE: For UTF-16 as well as for UTF-8 a Byte Order Mark is prepended. You will find it in the HEX Editor. It's 0xFF 0xFE for UTF-16 and 0xEF 0xBB 0xBF for UTF-8. The BOM is necessary to tell the parsing program what character set is used, but it could also cause problems with programs which cannot handle it.

Try the following:

Code:

Const strCsv = "TWN_VF_SDI.csv"
Const srtSeparator = ","

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
Set objFolder = objFSO.GetFolder(objFSO.GetParentFolderName(WScript.ScriptFullName))

Set objADOS = CreateObject("ADODB.Stream")
objADOS.Type = 2
objADOS.Open
objADOS.Charset = "UTF-8"


For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then
    Set objWB = objXL.Workbooks.Open(objFile.Path)
    Set objWS = objWB.Worksheets(1)
    If objWS.Cells(8, 6).Text <> "" Then
      process_content
    End If
    Set objWS = Nothing
    objWB.Close False
    Set objWB = Nothing
  End If
Next

objADOS.Position = 0
objADOS.SaveToFile strCsv, 2
objADOS.Close

objXL.Quit
Set objXL = Nothing
MsgBox "Process finished for SDI Visit Forms. Check TWN_VF_SDI.csv file.", vbInformation, "Done"

'-----------------------------------------------------------------------------------------------'
Sub process_content()
    Dim arrLine(2), arrX(), arrY()
    arrLine(0) = objWS.Cells(5, 5).Text
    arrLine(1) = objWS.Cells(2, 2).Text
    arrLine(2) = objFile.Name
    line = 0
    column = 0
    Set objCell = objWS.Cells(8, 6)
    Do
      Redim Preserve arrY(line)
      arrY(line) = objCell.Offset(line, 0).Text
      If objCell.Offset(line + 1, 0).Text = "" Then Exit Do
      line = line + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(2, 7)
    Do
      Redim Preserve arrX(column)
      arrX(column) = objCell.Offset(0, column).Text
      If objCell.Offset(0, column + 1).Text = "" Then Exit Do
      column = column + 1
    Loop
    Set objCell = Nothing
    Set objCell = objWS.Cells(8, 7)
    For x = 0 To column
      For y = 0 To line

        objADOS.WriteText arrLine(0) & srtSeparator & arrLine(1) & srtSeparator & arrLine(2) & srtSeparator  & _
          arrY(y) & srtSeparator & arrX(x) & srtSeparator & objCell.Offset(y, x).Text & vbCrLf

      Next
    Next
    Set objCell = Nothing
End Sub

Do the same with your 2nd script.

Regards
GermanOne

 

I see. Now I know. UTF-8 is sufficient for capturing the Chinese Characters. I applied it on the second VBScript and it worked! Thank you so much GermanOne!