برای انجام این کار به صورت دستی ، باید موارد زیر را انجام دهم:
۱) اطلاعات را بر اساس نام یک نویسنده فیلتر کنید.
۲) داده های فیلتر شده را کپی کنید.
۳) یک شیت اضافه کنید.
۴) داده ها را جایگذاری کنید.
۵) شیت را تغییر نام دهید.
۶) برای هر کدام ۵ مرحله بالا را تکرار کنید.
در این مثال ، من فقط سه نام دارم. تصور کنید که ۱۰۰ اسم دارید. چگونه می توانید داده ها را به شیت های مختلف تقسیم کنید؟ زمان زیادی می برد و شما را نیز خسته می کند.
جداسازی خودکار داده ها در اکسل بر اساس ستون خاص
۱. کلیدهای Alt + F11 را فشار دهید تا پنجره Microsoft Visual Basic for Applications باز شود .
۲. در پنجره Microsoft Visual Basic for Applications بر رویInsert > Module کلیک کنید و سپس از زیر کد VBA را کپی و در درون پنجره ماژول قراردهید .
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 |
Sub SplitIntoSheets() With Application .ScreenUpdating = False .DisplayAlerts = False End With ThisWorkbook.Activate Sheet1.Activate 'clearing filter if any On Error Resume Next Sheet1.ShowAllData On Error GoTo 0 Dim lsrClm As Long Dim lstRow As Long 'counting last used row lstRow = Cells(Rows.Count, 1).End(xlUp).Row Dim uniques As Range Dim clm As String, clmNo As Long On Error GoTo handler clm = Application.InputBox("From which column you want create files" & vbCrLf & "E.g. A,B,C,AB,ZA etc.") clmNo = Range(clm & "1").Column Set uniques = Range(clm & "2:" & clm & lstRow) 'Calling Remove Duplicates to Get Unique Names Set uniques = RemoveDuplicates(uniques) Call CreateSheets(uniques, clmNo) With Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With Sheet1.Activate MsgBox "Well Done!" Exit Sub Data.ShowAllData handler: With Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With End Sub Function RemoveDuplicates(uniques As Range) As Range ThisWorkbook.Activate Sheets.Add On Error Resume Next ActiveSheet.Name = "uniques" Sheets("uniques").Activate On Error GoTo 0 uniques.Copy Cells(2, 1).Activate ActiveCell.PasteSpecial xlPasteValues Range("A1").Value = "uniques" Dim lstRow As Long lstRow = Cells(Rows.Count, 1).End(xlUp).Row Range("A2:A" & lstRow).Select ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=1, Header:=xlNo lstRow = Cells(Rows.Count, 1).End(xlUp).Row Set RemoveDuplicates = Range("A2:A" & lstRow) End Function Sub CreateSheets(uniques As Range, clmNo As Long) Dim lstClm As Long Dim lstRow As Long For Each unique In uniques Sheet1.Activate lstRow = Cells(Rows.Count, 1).End(xlUp).Row lstClm = Cells(1, Columns.Count).End(xlToLeft).Column Dim dataSet As Range Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm)) dataSet.AutoFilter field:=clmNo, Criteria1:=unique.Value lstRow = Cells(Rows.Count, 1).End(xlUp).Row lstClm = Cells(1, Columns.Count).End(xlToLeft).Column Debug.Print lstRow; lstClm Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm)) dataSet.Copy Sheets.Add ActiveSheet.Name = unique.Value2 ActiveCell.PasteSpecial xlPasteAll Next unique End Sub |
نکته: هنگامی که ماکرو (SplitIntoSheets) را اجرا می کنید ، بر اساس ستون داده شده ، شیت به چند شیت دیگر تقسیم می شود. می توانید دکمه ای را روی صفحه اضافه کنید و این ماکرو را به آن اختصاص دهید.
بعد از اجرای ماکرو پنجره ای ظاهر می شود که ستون موردنظر را از شما می خواهد.
پس از ورود نام ستون بر روی ok کلیک کرده، پنجره دیگری باز می شود که نشان از پایان کار می باشد.
ترجمه شده از سایت www.extendoffice.com
