adjust vbscript to create additional CSV file containing column contents only

Thanks to rorya, I've got a script (see code below) that processes csv files, manipulating text and creating new columns as necessary. I need to add (yet) another function. The script currently creates a new col 1 containing concatenated data from other columns. Now, I need to create a new csv file that contains col1 data ONLY with a header row of RecordID. That is, all other functionality of the script must stay, but now I also need to output a 2nd file containing only processed col1 data called RecordIDs.csv.

Big deal? Piece of cake? I don't know. Very heavy lifting for me though. Who can do it?

I've attached the code, a sample input file, and the text files the code reads in to make various changes to input. Topic.csv StateList.txt ReplacementList.txt
Function pd(n, totalDigits) 
        if totalDigits > len(n) then 
            pd = String(totalDigits-len(n),"0") & n 
        else 
            pd = n 
        end if 
End Function 

dteStart = Now


Dim Today

Today = pd(Month(date()),2) & "-" & _ 
        pd(Day(date()),2) & "-" & _ 
        Year(date())

Dim FileSys, MoveFile, i
Dim MyData, strData(), strStateData(), SplitUsingEqualTo, Search, strLine, strStateLine
Dim aCell

Const xlCellTypeLastCell = 11
Const xlCSV = 6
Const ForReading = 1

'~~> Change Path Here
InPutDirName = "C:\A_Testing\csvInput\"
OutPutDirName = "C:\A_Testing\csvOutput\"
ProcessedDirName = "C:\A_Testing\csvProcessed\"
ReplacementTextFile = "C:\A_Testing\csvProcessed\ReplacementList.txt"
StateTextFile = "C:\A_Testing\csvProcessed\StateList.txt"

Set objExcel = CreateObject("Excel.Application")
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objTextFile = FileSys.OpenTextFile(ReplacementTextFile, ForReading)
Set objStateTextFile = FileSys.OpenTextFile(StateTextFile, ForReading)

Set FileRetriever = FileSys.GetFolder(InPutDirName)
Set FileNames = FileRetriever.Files
 
i = 0

Do Until objTextFile.AtEndOfStream
    ReDim Preserve strData(i)
    strData(i) = objTextFile.ReadLine
    i = i + 1
Loop
objTextFile.Close
 
j = 0

Do Until objStateTextFile.AtEndOfStream
    ReDim Preserve strStateData(j)
    strStateData(j) = objStateTextFile.ReadLine
    j = j + 1
Loop
objStateTextFile.Close

For Each F In FileNames
    If LCase(Right(CStr(F.Name), 4)) = ".csv" Then
        Set objWorkbook = objExcel.Workbooks.Open(InPutDirName & F.Name)
        Set objSheet = objWorkbook.Sheets(1)
        topicName = Replace(F.Name,".csv","")
        lastrow = objSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
        objSheet.Columns(1).Insert
        objSheet.Cells(1, "A") = "RecordID"
        objSheet.Range("A2:A" & lastrow).FormulaR1C1 = "=RC[1]&RC[2]&RC[3]&RC[4]&RC[5]"
        objSheet.Cells(1, "Y") = "Topic"
        objSheet.Range("Y2:Y" & lastrow).FormulaR1C1 = topicName         
        
        objExcel.DisplayAlerts = False
        
        For Each strLine In strData
            SplitUsingEqualTo = Split(strLine, "=") 
            objSheet.Columns(24).Replace SplitUsingEqualTo(0), SplitUsingEqualTo(1),2,1,True
  Next
  
       objSheet.Range("A2:A" & lastrow).value = objSheet.Range("A2:A" & lastrow).value
        For Each strStateLine In strStateData
            SplitUsingEqualTo = Split(strStateLine, "=") 
            objSheet.Columns(2).Replace SplitUsingEqualTo(0), SplitUsingEqualTo(1),1,1,True
            
        Next
        
        objWorkbook.SaveAs OutPutDirName & Replace(F.Name,".csv"," " & Today & ".csv"), xlCSV
				objWorkbook.Close (True)
				objExcel.DisplayAlerts = True
				objExcel.Quit
				FileSys.MoveFile InPutDirName & F.Name , ProcessedDirName & Replace(F.Name,".csv"," processed " & Today & ".csv")
        'Set MoveFile = FileSys.GetFile(InPutDirName & F.Name)
        'MoveFile.Move (ProcessedDirName)
    End If
Next

dteEnd = Now

MsgBox "Finished in " & DateDiff("s", dteStart, dteEnd) & " seconds."

Open in new window

GessWurkerAsked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
RobSampsonConnect With a Mentor Commented:
I've made it create a <filename>_RecordIDs.csv file.  I haven't tested this, but hopefully it works.

Regards,

Rob.
Function pd(n, totalDigits) 
        if totalDigits > len(n) then 
            pd = String(totalDigits-len(n),"0") & n 
        else 
            pd = n 
        end if 
End Function 

dteStart = Now


Dim Today

Today = pd(Month(date()),2) & "-" & _ 
        pd(Day(date()),2) & "-" & _ 
        Year(date())

Dim FileSys, MoveFile, i
Dim MyData, strData(), strStateData(), SplitUsingEqualTo, Search, strLine, strStateLine
Dim aCell

Const xlCellTypeLastCell = 11
Const xlCSV = 6
Const ForReading = 1

'~~> Change Path Here
InPutDirName = "C:\A_Testing\csvInput\"
OutPutDirName = "C:\A_Testing\csvOutput\"
ProcessedDirName = "C:\A_Testing\csvProcessed\"
ReplacementTextFile = "C:\A_Testing\csvProcessed\ReplacementList.txt"
StateTextFile = "C:\A_Testing\csvProcessed\StateList.txt"

Set objExcel = CreateObject("Excel.Application")
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objTextFile = FileSys.OpenTextFile(ReplacementTextFile, ForReading)
Set objStateTextFile = FileSys.OpenTextFile(StateTextFile, ForReading)

Set FileRetriever = FileSys.GetFolder(InPutDirName)
Set FileNames = FileRetriever.Files
 
i = 0

Do Until objTextFile.AtEndOfStream
    ReDim Preserve strData(i)
    strData(i) = objTextFile.ReadLine
    i = i + 1
Loop
objTextFile.Close
 
j = 0

Do Until objStateTextFile.AtEndOfStream
    ReDim Preserve strStateData(j)
    strStateData(j) = objStateTextFile.ReadLine
    j = j + 1
Loop
objStateTextFile.Close

For Each F In FileNames
    If LCase(Right(CStr(F.Name), 4)) = ".csv" Then
        Set objWorkbook = objExcel.Workbooks.Open(InPutDirName & F.Name)
        Set objSheet = objWorkbook.Sheets(1)
        topicName = Replace(F.Name,".csv","")
        lastrow = objSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
        objSheet.Columns(1).Insert
        objSheet.Cells(1, "A") = "RecordID"
        objSheet.Range("A2:A" & lastrow).FormulaR1C1 = "=RC[1]&RC[2]&RC[3]&RC[4]&RC[5]"
        objSheet.Cells(1, "Y") = "Topic"
        objSheet.Range("Y2:Y" & lastrow).FormulaR1C1 = topicName         
        
        objExcel.DisplayAlerts = False
        
        For Each strLine In strData
            SplitUsingEqualTo = Split(strLine, "=") 
            objSheet.Columns(24).Replace SplitUsingEqualTo(0), SplitUsingEqualTo(1),2,1,True
  Next
  
       objSheet.Range("A2:A" & lastrow).value = objSheet.Range("A2:A" & lastrow).value
        For Each strStateLine In strStateData
            SplitUsingEqualTo = Split(strStateLine, "=") 
            objSheet.Columns(2).Replace SplitUsingEqualTo(0), SplitUsingEqualTo(1),1,1,True
            
        Next
        
	    strRecordIDs = ProcessedDirName & Replace(F.Name,".csv"," " & Today & ".csv")
	    Set objRecordIDs = FileSys.CreateTextFile(strRecordIDs, True)
		For intRow = 2 To lastrow
			objRecordIDs.WriteLine objSheet.Cells(intRow, "A").Value
		Next
		objRecordIDs.Close
        objWorkbook.SaveAs OutPutDirName & Replace(F.Name,".csv"," " & Today & ".csv"), xlCSV
				objWorkbook.Close (True)
				objExcel.DisplayAlerts = True
				objExcel.Quit
				FileSys.MoveFile InPutDirName & F.Name , ProcessedDirName & Replace(F.Name,".csv"," processed " & Today & ".csv")
        'Set MoveFile = FileSys.GetFile(InPutDirName & F.Name)
        'MoveFile.Move (ProcessedDirName)
	    
    End If
Next

dteEnd = Now

MsgBox "Finished in " & DateDiff("s", dteStart, dteEnd) & " seconds."

Open in new window

0
 
RobSampsonCommented:
Hi, as this (potentially) processes multiple files at a time, do want each file to append to RecordIDs.csv, or do you want to make it <filename>_RecordIDs.csv or something like that?

Rob.
0
 
GessWurkerAuthor Commented:
Hi Rob. Thanks for your effort, but we lost the subject conversion aspect and I didn't find a second file <filename>_recordids.csv file.
0
Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

 
RobSampsonCommented:
Really? I didn't change anything. All I added was lines 85 to 90.....does the code you posted still do its required functions?

Rob.
strRecordIDs = ProcessedDirName & Replace(F.Name,".csv"," " & Today & ".csv")
		Set objRecordIDs = FileSys.CreateTextFile(strRecordIDs, True)
		For intRow = 2 To lastrow
			objRecordIDs.WriteLine objSheet.Cells(intRow, "A").Value
		Next
		objRecordIDs.Close

Open in new window

0
 
GessWurkerAuthor Commented:
My bad, Rob. I was looking in the wrong place for the file. Your code does the trick. That said, can we specify a folder destination for the new single column RecordID csv file? Something like:

RecIDDirName = "C:\A_Testing\csvRecID\"

I need the new file to end up in a separate folder.
0
 
RobSampsonConnect With a Mentor Commented:
Absolutely.  Add
RecIDDirName = "C:\A_Testing\csvRecID\"

under this
StateTextFile = "C:\A_Testing\csvProcessed\StateList.txt"

and then change this:
strRecordIDs = ProcessedDirName & Replace(F.Name,".csv"," " & Today & ".csv")

to this
strRecordIDs = RecIDDirName & Replace(F.Name,".csv"," " & Today & ".csv")


Regards,

Rob.
0
 
GessWurkerAuthor Commented:
Thanks, Rob!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.