چگونگی جداسازی خودکار داده ها در اکسل بر اساس ستون خاص

با سلام خدمت همراهان عزیز سایت آی تی سواد

اکسل نرم افزار آماری است که فضای راحتی را برای دسته بندی داده ها بوجود آورده. حال می خواهیم به این سوال پاسخ دهیم که چگونه جداسازی خودکار داده ها در اکسل را انجام دهیم ؟ به عنوان مثال ، من این داده ها را دارم ، که شامل ستون هایی به نام تاریخ ، نویسنده و عنوان هستند. می خواهم جداسازی داده ها بر اساس هر نویسنده را در شیت های جداگانه انجام دهم.

برای انجام این کار به صورت دستی ، باید موارد زیر را انجام دهم:

۱) اطلاعات را بر اساس نام یک نویسنده فیلتر کنید.
۲) داده های فیلتر شده را کپی کنید.
۳) یک شیت اضافه کنید.
۴) داده ها را جایگذاری کنید.
۵) شیت را تغییر نام دهید.
۶) برای هر کدام ۵ مرحله بالا را تکرار کنید.

در این مثال ، من فقط سه نام دارم. تصور کنید که ۱۰۰ اسم دارید. چگونه می توانید داده ها را به شیت های مختلف تقسیم کنید؟ زمان زیادی می برد و شما را نیز خسته می کند.

جداسازی خودکار داده ها در اکسل بر اساس ستون خاص

برای خودکارسازی فرایند جدا سازی داده ها بر اساس ستون خاص این مراحل را دنبال کنید.

۱. کلیدهای Alt + F11 را فشار دهید تا پنجره Microsoft Visual Basic for Applications باز شود .

۲. در پنجره Microsoft Visual Basic for Applications بر رویInsert > Module کلیک کنید و سپس از زیر کد VBA را کپی و در درون پنجره ماژول قراردهید .

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

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

ممنون از همراهی شما کاربران عزیز آی تی سواد

اشتراک گذاری

بیشتر

6 دیدگاه دربارهٔ «چگونگی جداسازی خودکار داده ها در اکسل بر اساس ستون خاص;

سمانه

مهر 6, 1400 در 3:31 بعد از ظهر

سلام خسته نباشید، من یه سوال دارم اینکه من چندتا عدد دارم که جلوی هر عدد یکسری اطلاعات هستش به نحوی که مثلا عدد یک رنگ قرمز وزن ۱۵ جنس سنگ قیمت ۵۰ و عدد دو رنگ سبز وزن ۸ جنس چوب و عدد سه فقط وزن وقیمت دارد و سلول رنگ خالی میباشد ، حالا من میخوام برنامه ای بنویسم که مثلا اگه عدد یک را تایپ کنم همه مشخصاتش را بهم نمایش بدهد. ممنون میشم اگه راهنماییم کنید .بینهایت سپاسگزارم
پاسخ
- حامد محمودخانی
  
  مهر 7, 1400 در 10:06 بعد از ظهر
  
  سلام
  از سری فرمول های جستجو مثل lookup ,vlookup,match&index می توانید کمک بگیرید
  پاسخ
مرتضی

دی 17, 1400 در 2:05 بعد از ظهر

با سلام و احترام.من یک سوال خیلی مهم دارم . میخواستم یک فایل اکسل که مربوط به گزارش قبوض ماهیانه شرکت برق است را تبدیل کنم به یک اکسل دیگر که دارای اطلاعات متفاوتی هست.مثلا میخوام این گذارش را بزارم تو شیت اول و بصورت خودکار شیت دوم اون اطلاعات شیت اول رو بر اساس شماره پرونده برام مرتب کنه و اطلاعات جدید رو بهم تحویل بده
پاسخ
- حامد محمودخانی
  
  دی 18, 1400 در 4:52 بعد از ظهر
  
  سلام
  نمونه از فایلتون و کاری که میخواید انجام بدید به آیدی @hamedmahmoudkhani در تلگرام ارسال کنید
  پاسخ
حسن

تیر 23, 1401 در 4:11 بعد از ظهر

با سلام و احترام من یک فایل اکسل برای ثبت اطلاعات تولیدی و انبار در کار گاهی که در ان کار میکنم درست کردم .و حدود یک ماه است که از فایل استفاده میکنیم . ولی یک مشکلی که دارم اینه که از همان ابتدا که فایل رو به صورت xlsm سیو کردم فایلم خیلی دیر بالا میاد یعنی حدود ۲تا۳دقیقه طول میکشه که فایلم باز بشه و یک چیز دیگه اینکه روی ایکون فایل اکسلم یک علامت تعجب هم همیشه هست خیلی ممنون میشم که راهنماییم کنیم سپاسگذارم
پاسخ
- حامد محمودخانی
  
  مرداد 16, 1401 در 10:27 بعد از ظهر
  
  سلام
  بررسی کنید افزونه ای روی اکسل شما فعال نباشد.ویندوز به فایل هایی که کدنویسی دارند حساس هست
  پاسخ

جداسازی خودکار داده ها در اکسل بر اساس ستون خاص

ممنون از همراهی شما کاربران عزیز آی تی سواد

6 دیدگاه دربارهٔ «چگونگی جداسازی خودکار داده ها در اکسل بر اساس ستون خاص;

دیدگاهتان را بنویسید لغو پاسخ