सीएसवी फाइलों को अलग करने के लिए प्रत्येक शीट को कार्यपुस्तिका में सहेजें

Question

मैक्रो के साथ CSV फ़ाइलों को अलग करने के लिए मैं प्रत्येक शीट को Excel कार्यपुस्तिका में कैसे सहेजूं?

मेरे पास एकाधिक चादरों के साथ एक एक्सेल है और मैं एक मैक्रो की तलाश में था जो प्रत्येक शीट को अलग CSV (comma separated file) पर सहेज लेगा। एक्सेल आपको सभी चादरों को विभिन्न CSV फ़ाइलों को सहेजने की अनुमति नहीं देगा।

Answer 1

यहाँ वह एक है जो आपको उस फ़ोल्डर को चुनने के लिए एक दृश्य फ़ाइल चयनकर्ता देगा जो आप फ़ाइलों को सहेजना चाहते हैं और आपको सीएसवी डिलीमीटर (मैं पाइप का उपयोग करता हूं 'चुनने देता हूं क्योंकि मेरे फ़ील्ड में अल्पविराम होते हैं और मैं इससे निपटना नहीं चाहता उद्धरण):

' ---------------------- Directory Choosing Helper Functions ----------------------- 
' Excel and VBA do not provide any convenient directory chooser or file chooser 
' dialogs, but these functions will provide a reference to a system DLL 
' with the necessary capabilities 
Private Type BROWSEINFO ' used by the function GetFolderName 
    hOwner As Long 
    pidlRoot As Long 
    pszDisplayName As String 
    lpszTitle As String 
    ulFlags As Long 
    lpfn As Long 
    lParam As Long 
    iImage As Long 
End Type 

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _ 
              Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long 
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _ 
              Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 

Function GetFolderName(Msg As String) As String 
    ' returns the name of the folder selected by the user 
    Dim bInfo As BROWSEINFO, path As String, r As Long 
    Dim X As Long, pos As Integer 
    bInfo.pidlRoot = 0& ' Root folder = Desktop 
    If IsMissing(Msg) Then 
     bInfo.lpszTitle = "Select a folder." 
     ' the dialog title 
    Else 
     bInfo.lpszTitle = Msg ' the dialog title 
    End If 
    bInfo.ulFlags = &H1 ' Type of directory to return 
    X = SHBrowseForFolder(bInfo) ' display the dialog 
    ' Parse the result 
    path = Space$(512) 
    r = SHGetPathFromIDList(ByVal X, ByVal path) 
    If r Then 
     pos = InStr(path, Chr$(0)) 
     GetFolderName = Left(path, pos - 1) 
    Else 
     GetFolderName = "" 
    End If 
End Function 
'---------------------- END Directory Chooser Helper Functions ---------------------- 

Public Sub DoTheExport() 
    Dim FName As Variant 
    Dim Sep As String 
    Dim wsSheet As Worksheet 
    Dim nFileNum As Integer 
    Dim csvPath As String 


    Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _ 
        "Export To Text File") 
    'csvPath = InputBox("Enter the full path to export CSV files to: ") 

    csvPath = GetFolderName("Choose the folder to export CSV files to:") 
    If csvPath = "" Then 
     MsgBox ("You didn't choose an export directory. Nothing will be exported.") 
     Exit Sub 
    End If 

    For Each wsSheet In Worksheets 
     wsSheet.Activate 
     nFileNum = FreeFile 
     Open csvPath & "\" & _ 
      wsSheet.Name & ".csv" For Output As #nFileNum 
     ExportToTextFile CStr(nFileNum), Sep, False 
     Close nFileNum 
    Next wsSheet 

End Sub 



Public Sub ExportToTextFile(nFileNum As Integer, _ 
          Sep As String, SelectionOnly As Boolean) 

    Dim WholeLine As String 
    Dim RowNdx As Long 
    Dim ColNdx As Integer 
    Dim StartRow As Long 
    Dim EndRow As Long 
    Dim StartCol As Integer 
    Dim EndCol As Integer 
    Dim CellValue As String 

    Application.ScreenUpdating = False 
    On Error GoTo EndMacro: 

    If SelectionOnly = True Then 
     With Selection 
      StartRow = .Cells(1).Row 
      StartCol = .Cells(1).Column 
      EndRow = .Cells(.Cells.Count).Row 
      EndCol = .Cells(.Cells.Count).Column 
     End With 
    Else 
     With ActiveSheet.UsedRange 
      StartRow = .Cells(1).Row 
      StartCol = .Cells(1).Column 
      EndRow = .Cells(.Cells.Count).Row 
      EndCol = .Cells(.Cells.Count).Column 
     End With 
    End If 

    For RowNdx = StartRow To EndRow 
     WholeLine = "" 
     For ColNdx = StartCol To EndCol 
      If Cells(RowNdx, ColNdx).Value = "" Then 
       CellValue = "" 
      Else 
       CellValue = Cells(RowNdx, ColNdx).Value 
      End If 
      WholeLine = WholeLine & CellValue & Sep 
     Next ColNdx 
     WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) 
     Print #nFileNum, WholeLine 
    Next RowNdx 

EndMacro: 
    On Error GoTo 0 
    Application.ScreenUpdating = True 

End Sub 

Answer 2

और यहाँ मेरे समाधान एक्सेल> 2000 के साथ काम करना चाहिए है, लेकिन केवल 2007 को परीक्षण किया:

Private Sub SaveAllSheetsAsCSV() 
On Error GoTo Heaven 

' each sheet reference 
Dim Sheet As Worksheet 
' path to output to 
Dim OutputPath As String 
' name of each csv 
Dim OutputFile As String 

Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Application.EnableEvents = False 

' ask the user where to save 
OutputPath = InputBox("Enter a directory to save to", "Save to directory", Path) 

If OutputPath <> "" Then 

    ' save for each sheet 
    For Each Sheet In Sheets 

     OutputFile = OutputPath & "\" & Sheet.Name & ".csv" 

     ' make a copy to create a new book with this sheet 
     ' otherwise you will always only get the first sheet 
     Sheet.Copy 
     ' this copy will now become active 
     ActiveWorkbook.SaveAs FileName:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False 
     ActiveWorkbook.Close 
    Next 

End If 

Finally: 
Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
Application.EnableEvents = True 

Exit Sub 

Heaven: 
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _ 
     "Source: " & Err.Source & " " & vbCrLf & _ 
     "Number: " & Err.Number & " " & vbCrLf & _ 
     "Description: " & Err.Description & " " & vbCrLf 

GoTo Finally 
End Sub 

(ओटी: मुझे आश्चर्य है कि यदि ऐसा है तो मेरे नाबालिग ब्लॉगिंग को प्रतिस्थापित कर देगी)

Answer 3

@AlexDuggleby: आपको वर्कशीट की प्रतिलिपि बनाने की आवश्यकता नहीं है, आप उन्हें सीधे सहेज सकते हैं। उदाहरण:

Public Sub SaveWorksheetsAsCsv() 
Dim WS As Excel.Worksheet 
Dim SaveToDirectory As String 

    SaveToDirectory = "C:\" 

    For Each WS In ThisWorkbook.Worksheets 
     WS.SaveAs SaveToDirectory & WS.Name, xlCSV 
    Next 

End Sub 

केवल संभावित समस्या यह है कि आपकी कार्यपुस्तिका अंतिम सीएसवी फ़ाइल के रूप में सहेजी जाती है। यदि आपको मूल कार्यपुस्तिका रखने की आवश्यकता है तो आपको इसे सहेजने की आवश्यकता होगी।

Answer 4

ग्राहम के उत्तर पर बिल्डिंग, अतिरिक्त कोड कार्यपुस्तिका को इसके मूल प्रारूप में वापस अपने मूल स्थान में सहेजता है।

Public Sub SaveWorksheetsAsCsv() 

Dim WS As Excel.Worksheet 
Dim SaveToDirectory As String 

Dim CurrentWorkbook As String 
Dim CurrentFormat As Long 

CurrentWorkbook = ThisWorkbook.FullName 
CurrentFormat = ThisWorkbook.FileFormat 
' Store current details for the workbook 

     SaveToDirectory = "C:\" 

     For Each WS In ThisWorkbook.Worksheets 
      WS.SaveAs SaveToDirectory & WS.Name, xlCSV 
     Next 

Application.DisplayAlerts = False 
    ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat 
Application.DisplayAlerts = True 
' Temporarily turn alerts off to prevent the user being prompted 
' about overwriting the original file. 

End Sub 

Answer 5

एक छोटा संशोधन to answer from Alex स्वत: गणना के चालू और बंद हो रहा है।

आश्चर्यजनक रूप से असम्बद्ध कोड VLOOKUP के साथ ठीक काम कर रहा था लेकिन ऑफसेट के साथ विफल रहा। ऑटो गणना को भी तेजी से बचाने के लिए गति को बंद कर दें।

Public Sub SaveAllSheetsAsCSV() 
On Error GoTo Heaven 

' each sheet reference 
Dim Sheet As Worksheet 
' path to output to 
Dim OutputPath As String 
' name of each csv 
Dim OutputFile As String 

Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Application.EnableEvents = False 

' Save the file in current director 
OutputPath = ThisWorkbook.Path 


If OutputPath <> "" Then 
Application.Calculation = xlCalculationManual 

' save for each sheet 
For Each Sheet In Sheets 

    OutputFile = OutputPath & Application.PathSeparator & Sheet.Name & ".csv" 

    ' make a copy to create a new book with this sheet 
    ' otherwise you will always only get the first sheet 

    Sheet.Copy 
    ' this copy will now become active 
    ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlCSV,  CreateBackup:=False 
    ActiveWorkbook.Close 
Next 

Application.Calculation = xlCalculationAutomatic 

End If 

Finally: 
Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
Application.EnableEvents = True 

Exit Sub 

Heaven: 
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _ 
     "Source: " & Err.Source & " " & vbCrLf & _ 
     "Number: " & Err.Number & " " & vbCrLf & _ 
     "Description: " & Err.Description & " " & vbCrLf 

GoTo Finally 
End Sub 

Answer 6

कृपया/उसे Von Pookie's answer गौर, सभी क्रेडिट उसे।

Sub asdf() 
Dim ws As Worksheet, newWb As Workbook 

Application.ScreenUpdating = False 
For Each ws In Sheets(Array("EID Upload", "Wages with Locals Upload", "Wages without Local Upload")) 
    ws.Copy 
    Set newWb = ActiveWorkbook 
    With newWb 
     .SaveAs ws.Name, xlCSV 
     .Close (False) 
    End With 
Next ws 
Application.ScreenUpdating = True 

End Sub