Hi
try this
Code:
Sub kTest()
Dim k, i As Long, j As Long, a() As String, n As Long
Dim wbkNew As Workbook, r As Range, c As Long
With Worksheets("Sheet1")
On Error Resume Next
With .Range("a2:ac" & .UsedRange.Rows.Count)
Set r = .Columns(1).SpecialCells(xlCellTypeConstants, 23)
c = .Columns.Count
End With
End With
If Not r Is Nothing Then
For i = 1 To r.Areas.Count
With r.Areas(i).Resize(, c)
Debug.Print .Address
.UnMerge
.SpecialCells(4).FormulaR1C1 = "=r[-1]c"
k = .Value2
End With
For j = 1 To UBound(k, 1)
n = n + 1
ReDim Preserve a(1 To n)
a(n) = Join(Application.Index(k, j, 0), "|")
Next
Next
If n Then
Set wbkNew = Workbooks.Add(xlWBATWorksheet)
With wbkNew.Worksheets(1)
.Range("a1").Resize(n) = Application.Transpose(a)
.Range("a1").Resize(n).TextToColumns .Range("A1"), 1, Other:=True, OtherChar:="|"
.Range("i1").Resize(n).TextToColumns .Range("i1"), 1, , FieldInfo:=Array(1, 5)
.Range("j1").Resize(n).TextToColumns .Range("j1"), 1, , FieldInfo:=Array(1, 5)
End With
wbkNew.SaveAs ThisWorkbook.Path & "\" & "CSVFileName.CSV", 6
wbkNew.Close 0
Set wbkNew = Nothing
End If
End If
End Sub
Bookmarks