Hi Please Paste both codes and Change Red Items according to Your Need activate the Sheet where data is and run the code------------
Code:
Option Explicit
Sub SaveExcelasCSV()
Dim strFirstCSVName As String
Dim strSecondCSVName As String
Dim strFirstTable As String
Dim strSecondTable As String
Dim strSaveLocation As String
Dim strCSV_1_Columns As String
Dim strCSV_2_Columns As String
Dim strRange As String
Dim wksAct As Worksheet
Dim wbkNew As Workbook
Dim rngUsedRng As Range
Dim lngLastRow As Long
''''''''' Change According to your requirement================
strFirstCSVName = "First"
strSecondCSVName = "Second"
strFirstTable = "FirstTable"
strSecondCSVName = "SecondTable"
strCSV_1_Columns = "A:C,E,G,I" ' Let Say Column A to C and Columns E, G, and I
strCSV_2_Columns = "D,F,H,J:L" ' Let Say Columns D,F,H and Columns J to L
strSaveLocation = "C:\Users\kbdf775\Desktop\"
'''''''''===============================================
Set wksAct = ActiveSheet
Set wbkNew = Workbooks.Add(1)
With wksAct
Set rngUsedRng = .UsedRange
lngLastRow = rngUsedRng.Rows.Count
strRange = MakeRange(strCSV_1_Columns)
.Range(strRange).Copy
wbkNew.Sheets(1).Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
wbkNew.Sheets(1).Rows(1).Insert
wbkNew.Sheets(1).Rows(1).Insert
wbkNew.Sheets(1).Cells(1).Value = strFirstTable
Application.DisplayAlerts = False
wbkNew.SaveAs Filename:=strSaveLocation & strFirstCSVName, FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = True
wbkNew.Sheets(1).Cells.Clear
strRange = MakeRange(strCSV_2_Columns)
.Range(strRange).Copy
wbkNew.Sheets(1).Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
wbkNew.Sheets(1).Rows(1).Insert
wbkNew.Sheets(1).Rows(1).Insert
wbkNew.Sheets(1).Cells(1).Value = strSecondTable
Application.DisplayAlerts = False
wbkNew.SaveAs Filename:=strSaveLocation & strSecondCSVName, FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = True
wbkNew.Close 0
End With
End Sub
Code:
Function MakeRange(strString As String)
Dim varSplit As Variant
Dim lngVar As Long
Dim strMain As String
varSplit = Split(strString, ",")
For lngVar = 0 To UBound(varSplit)
If Len(varSplit(lngVar)) = 1 Or InStr(1, varSplit(lngVar), ":") = 0 Then
If strMain = "" Then
strMain = varSplit(lngVar) & ":" & varSplit(lngVar)
Else
strMain = strMain & "," & varSplit(lngVar) & ":" & varSplit(lngVar)
End If
Else
If strMain = "" Then
strMain = varSplit(lngVar)
Else
strMain = strMain & "," & varSplit(lngVar)
End If
End If
Next
MakeRange = strMain
End Function
HTH
---------------------------------------------------------
Bookmarks