fx Practical VBA Projects
ENहिन्दी

Sheet splitter — एक शीट को कॉलम वैल्यू के हिसाब से अलग फ़ाइलों में

⏱ 15 min

आप क्या सीखेंगे

  • काम
  • योजना
  • कोड

समझिए

1. काम

Data शीट में सारे रीजन की बिक्री है। हर महीने आप North फ़िल्टर करते हैं, कॉपी करते हैं, नई फ़ाइल में पेस्ट करते हैं, North.xlsx नाम से सेव करते हैं… और हर रीजन के लिए यही दोहराते हैं। मैक्रो यह सेकंडों में करता है।

A B C D E
1 Date Salesperson Region Product Amount
2 01-Apr Amit North Laptop 55000
3 03-Apr Neha South Mobile 18000
… … … … … …

2. योजना

  1. स्प्लिट कॉलम (Region) की हर अलग वैल्यू ढूँढो।
  2. हर वैल्यू के लिए: डेटा फ़िल्टर करो, दिखने वाली रो (हेडर समेत) नई वर्कबुक में कॉपी करो, सेव करो, बंद करो।
  3. सब कुछ वापस सामान्य करो और बताओ कितनी फ़ाइलें बनीं।

3. कोड

Insert → Module करके यह पेस्ट करें:

Option Explicit

Sub SplitByColumn()
    Const SHEET_NAME As String = "Data"
    Const KEY_COL As Long = 3                 ' column C = Region

    Dim ws As Worksheet, wbNew As Workbook
    Dim dataRng As Range
    Dim lastRow As Long, i As Long
    Dim folder As String, fileName As String
    Dim keys As Collection, k As Variant
    Dim seen As String

    On Error GoTo ErrHandler
    Set ws = ThisWorkbook.Worksheets(SHEET_NAME)
    lastRow = ws.Cells(ws.Rows.Count, KEY_COL).End(xlUp).Row
    If lastRow < 2 Then
        MsgBox "No data to split.", vbInformation
        Exit Sub
    End If
    Set dataRng = ws.Range("A1").CurrentRegion

    ' 1) Output folder next to this file
    folder = ThisWorkbook.Path & Application.PathSeparator & "Split_" & Format(Date, "yyyy-mm-dd")
    If Dir(folder, vbDirectory) = "" Then MkDir folder

    ' 2) Unique values (Collection works on Windows and Mac)
    Set keys = New Collection
    seen = "|"
    For i = 2 To lastRow
        k = Trim(CStr(ws.Cells(i, KEY_COL).Value))
        If Len(k) > 0 And InStr(1, seen, "|" & k & "|", vbTextCompare) = 0 Then
            keys.Add k
            seen = seen & k & "|"
        End If
    Next i

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ' 3) One file per value
    For Each k In keys
        If ws.AutoFilterMode Then ws.AutoFilterMode = False
        dataRng.AutoFilter Field:=KEY_COL, Criteria1:=k

        Set wbNew = Workbooks.Add(xlWBATWorksheet)
        dataRng.SpecialCells(xlCellTypeVisible).Copy wbNew.Worksheets(1).Range("A1")
        With wbNew.Worksheets(1)
            .Name = Left(SafeName(CStr(k)), 31)
            .Rows(1).Font.Bold = True
            .Columns.AutoFit
        End With

        fileName = folder & Application.PathSeparator & SafeName(CStr(k)) & ".xlsx"
        wbNew.SaveAs fileName:=fileName, FileFormat:=xlOpenXMLWorkbook
        wbNew.Close SaveChanges:=False
    Next k

    MsgBox keys.Count & " files saved in:" & vbCrLf & folder, vbInformation

CleanExit:
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox "Split failed: " & Err.Description, vbExclamation
    Resume CleanExit
End Sub

' Removes characters that are not allowed in file or sheet names
Private Function SafeName(ByVal s As String) As String
    Dim ch As Variant
    For Each ch In Array("\", "/", ":", "*", "?", """", "<", ">", "|", "[", "]")
        s = Replace(s, ch, "-")
    Next ch
    SafeName = s
End Function

4. यह कैसे काम करता है

  • अलग-अलग वैल्यू: एक आसान टेक्स्ट लिस्ट seen याद रखती है कि क्या पहले जुड़ चुका है। (कई ट्यूटोरियल Scripting.Dictionary इस्तेमाल करते हैं, जो बहुत बड़ी लिस्ट के लिए तेज़ है पर Mac पर मौजूद नहीं।)
  • AutoFilter + SpecialCells(xlCellTypeVisible): हेडर और सिर्फ़ मेल खाने वाली रो कॉपी करता है।
  • Workbooks.Add(xlWBATWorksheet): ठीक एक शीट वाली नई फ़ाइल।
  • FileFormat:=xlOpenXMLWorkbook: सामान्य .xlsx के रूप में सेव (आउटपुट में कोई मैक्रो नहीं)।
  • SafeName: "North/East" जैसा रीजन फ़ाइल नाम तोड़ देता; यह "North-East" बन जाता है।
  • तारीख़ वाला फ़ोल्डर: हर रन Split_2026-10-01 में जाता है, ताकि पिछले महीने की फ़ाइलें गलती से न बदलें।

5. अपने हिसाब से बदलें

  • Salesperson से स्प्लिट: KEY_COL को 2 करें।
  • दूसरी शीट: SHEET_NAME बदलें।
  • फ़ाइलों की जगह शीट: Workbooks.Add … Close वाले हिस्से को ThisWorkbook.Worksheets.Add(After:=…) से बदलें और वहाँ पेस्ट करें।
  • सिर्फ़ वैल्यू रखें: कॉपी के बाद wbNew.Worksheets(1).UsedRange.Value = wbNew.Worksheets(1).UsedRange.Value जोड़ें।

6. बटन जोड़ें

Developer → Insert → Button (Form Control) → बनाएँ → SplitByColumn असाइन करें। अब कोई भी एक क्लिक में चला सकता है।

आम गलतियाँ

मास्टर फ़ाइल सेव किए बिना चलाना (नई बिना सेव की फ़ाइल का ThisWorkbook.Path खाली होता है)। रीजन कॉलम में खाली सेल। / या : वाले रीजन नाम (SafeName संभालता है)। A1 से शुरू न होने वाला डेटा (CurrentRegion गलत ब्लॉक पकड़ता है)।

अभ्यास

medium4 रीजन वाला 30 रो का सेल्स डेटा बनाएँ। मैक्रो चलाएँ, कुछ आउटपुट फ़ाइलें खोलें और मास्टर में फ़िल्टर से गिनती मिलाएँ। फिर इसे Salesperson से स्प्लिट करने के लिए बदलें और values-only लाइन जोड़ें।
Sales की 30 rows में North 8, South 8, East 7, West 7 हैं। हर output में एक header तथा उसी region की rows हों। Salesperson से split करने पर Asha, Ravi, Meera की 10-10 rows आएँ। Copy के बाद outputRange.Value = outputRange.Value करें और filenames के अवैध अक्षर हटाएँ।

प्रश्नोत्तरी

सिर्फ़ फ़िल्टर हुई रो कौन कॉपी करता है?
SpecialCells(xlCellTypeVisible)
तारीख़ वाला आउटपुट फ़ोल्डर क्यों?
ताकि पुरानी फ़ाइलें कभी ओवरराइट न हों
नई फ़ाइल को सामान्य .xlsx में कौन-सी लाइन सेव करती है?
FileFormat:=xlOpenXMLWorkbook के साथ SaveAs
Sheet splitter — एक शीट को कॉलम वैल्यू के हिसाब से अलग फ़ाइलों में · हिंदी | ExcelWalaa