Fix concatenation method and include separators

Well, in order to read each record correctly, you are going to have to end up with a string which contains enough column separators (;) for the import process to properly put "Subject5", "Subject7", and "Subject11" in the appropriate columns.  So if a particular record contains no other information than those three text columns, then your string will always look like this.

I wrote an article a while back about parsing a CSV file prior to importing into Access, which should work similarly for your import into Excel.  Check it out at:

Thanks. The script I'm using is many years old, not originally written by me and only slightly modified my me over the years (as necessary and as I was able). However, this latest mod goes beyond my skill level. I'll keep at it. Here's a snippet of the relevant portions:

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","")
        If LCase(topicName) = "employeeleave" Then topicName = "Employee Leave" End If
        lastrow = objSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
        objSheet.Cells(1, "X") = "Subject"
        objSheet.Range("X2:X" & lastrow).FormulaR1C1 = "=RC[5] & "";"" & RC[6] & "";"" & RC[7] & "";""& RC[8] & "";"" & RC[9] & "";"" & RC[10] & "";"" & RC[11] & "";"" & RC[12] & "";"" & RC[13] & "";"" & RC[14] & "";"" & RC[15] & "";"" & RC[16]"  'Sort of works. Problematic.
      ' DOES NOT WORK objSheet.Range("X2:X" & lastrow).FormulaR1C1 = "=TEXTJOIN("";"",TRUE,RC[5]:RC[16])" 'DOES NOT WORK
      objSheet.Cells(1, "Y") = "Topic"
        objSheet.Range("Y2:Y" & lastrow).FormulaR1C1 = topicName        
        objSheet.Cells(1, "Z") = "StateNetModified"
        objSheet.Range("Z2:Z" & lastrow).FormulaR1C1 = Today        
        objSheet.Cells(1, "AA") = "ForFederalSort"
        objSheet.Range("AA2:AA" & lastrow).FormulaR1C1 = "=if(RC[-26]=""US"",""Federal"","""")"
        objSheet.Cells(1, "AB") = "NoMajorChanges"
        objSheet.Range("AB2:AB" & lastrow).FormulaR1C1 = bulletChar        
        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]&RC[25]"
        objSheet.Range("A2:A" & lastrow).FormulaR1C1 = "=RC[1]&RC[2]&RC[3]&RC[4]&RC[5]"
'        Msgbox (CStr(objSheet.Range("K2").value))
        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

        'Msgbox SortText("Z;L;B;I;A;J")
'            objSheet.Range("K2:K" & lastrow).value = SortText(objSheet.Range("K2:K" & lastrow).value)
 
    'Reads all Values From column K and try to apply the function
    Dim objRange
    Dim intRow
    Dim strColValue
    Set objRange = objSheet.Range("L2")
   
    For intRow = 1 To (lastrow - 1)
      strColValue = SortText(objRange(intRow, 1).Value)
        objRange(intRow, 1).Value = SortText(strColValue)
    Next

    'Reverse sorting Status Field
    Dim objRangeRev
    Dim intRowRev
    Dim strColValueRev
    Set objRangeRev = objSheet.Range("V2")
   
    For intRowRev = 1 To (lastrow - 1)
      strColValueRev = objRangeRev(intRowRev, 1).Value
        objRangeRev(intRowRev, 1).Value = ReverseSortText(strColValueRev)
    Next

            
'            strRecordIDs = RecIDDirName & 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"," " & CreateGUID() & ".csv"), xlCSV
'doesn't work, breaks concatenation of subjects            objSheet.Columns("AN").EntireColumn.Delete            
                        objWorkbook.Close (True)
                        objExcel.DisplayAlerts = True
                        objExcel.Quit
                        FileSys.MoveFile InPutDirName & F.Name , ProcessedDirName & Replace(F.Name,".csv"," processed " & CreateGUID() & ".csv")
        'Set MoveFile = FileSys.GetFile(InPutDirName & F.Name)
        'MoveFile.Move (ProcessedDirName)
    End If
Next

Ejgil - Worked perfectly!  Cheers. Only slightly altered:

            objSheet.Range("X2:X" & lastrow).FormulaR1C1 = "=RC[5]&IF(RC[5]<>"""","";"","""")&RC[6]&IF(RC[6]<>"""","";"","""")&RC[7]&IF(RC[7]<>"""","";"","""")&RC[8]&IF(RC[8]<>"""","";"","""")&RC[9]&IF(RC[9]<>"""","";"","""")&RC[10]&IF(RC[10]<>"""","";"","""")&RC[11]&IF(RC[11]<>"""","";"","""")&RC[12]&IF(RC[12]<>"""","";"","""")&RC[13]&IF(RC[13]<>"""","";"","""")&RC[14]&IF(RC[14]<>"""","";"","""")"

Thanks so much!

Why not use a UDF?

Function ConcatWOBlanks(rng As Range, Optional ConcatChar = ";") As String
Dim cl As Range
Dim arrVals() As Variant
Dim Cnt As Long

    ReDim arrVals(1 To rng.Cells.Count)

    For Each cl In rng.Cells
        If cl.Value <> "" Then
            Cnt = Cnt + 1
            arrVals(Cnt) = cl.Value
       End If
   Next cl

   If Cnt > 0 Then
       ReDim Preserve arrVals(1 To Cnt)
       ConcatWOBlanks = Join(arrVals, ConcatChar)
   End If

End Function

Select allOpen in new window

You could use this in your code like this.

 objSheet.Range("X2:X" & lastrow).FormulaR1C1 = "=ConcatWOBlanks(RC[5]:RC[14], "";"")"

Select allOpen in new window

Hi, Norie. Your solution looks great, but it returns an error at the first line

Line 132: Function ConcatWOBlanks(rng As Range, Optional ConcatChar = ";") As String

Line: 132
Char: 29
Error: Expected ')'

How did you use the code I posted?

It would go in  a separate module and would be used in your existing code as I showed above.

My script contains several functions already. I added it AFTER a CreateGuid() function, like so:

Function CreateGUID()
  numChars = 10 'CHANGE this variable for the length of the characters after the date
  Randomize Timer
  Dim tmpCounter,tmpGUID
  tmpGUID = Right("0" & Month(Now()),2)
  tmpGUID = tmpGUID & "-" & Right("0" & Day(Now()),2)
  tmpGUID = tmpGUID & "-" & Right(Year(Now()),2) & "_"
  Const strValid = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  For tmpCounter = 1 To numChars
    tmpGUID = tmpGUID & Mid(strValid, Int(Rnd(1) * Len(strValid)) + 1, 1)
  Next
  CreateGUID = tmpGUID
End Function


Function ConcatWOBlanks(rng As Range, Optional ConcatChar = ";") As String
Dim cl As Range
Dim arrVals() As Variant
Dim Cnt As Long

    ReDim arrVals(1 To rng.Cells.Count)

    For Each cl In rng.Cells
        If cl.Value <> "" Then
            Cnt = Cnt + 1
            arrVals(Cnt) = cl.Value
       End If
   Next cl

   If Cnt > 0 Then
       ReDim Preserve arrVals(1 To Cnt)
       ConcatWOBlanks = Join(arrVals, ConcatChar)
   End If

End Function