طریقه تفکیک اطلاعات یک جدول در شیت‌های مختلف در اکسل

فرض کنید در یک شیت اکسل اطلاعات تاریخ و مدت زمان اضافه کاری کارمندان یک شرکت ثبت شده است بطوریکه در ستون اول نام افراد، در ستون دوم تاریخ و در ستون سوم مدت زمان اضافه کاری هر روز باشد. حال اگر بخواهید اطلاعات هر کارمند یا هر روز را در شیت‌های مختلف تفکیک کنید باید ابتدا اطلاعات را بر اساس معیار مدنظرتان فیلتر کنید و سپس با استفاده از کپی و پیست آن‌ها را به شیت‌های جداگانه منتقل کنید. اگر تعداد این اطلاعات زیاد باشد این روش ممکن است بسیار زمان‌بر باشد. در ادامه مطلب با۱۴ خورشید همراه باشید تا با روش‌های سریع‌تر انجام اینکار آشنا شوید.

در واقع آنچه که می‌خواهیم انجام دهیم در تصویر زیر نشان داده شده است:

روش ۱) ماکرونویسی

کلیدهای Alt + F11 را فشار هید یا از تب Developer قسمت code گزینه Visual Basic را انتخاب کنید. پنجره Microsoft Visual Basic ظاهر می‌شود. در این پنجره از تب Insert گزینه Module را انتخاب نمائید.

در پنجره جدید باز شده کدهای زیر را کپی کنید.

Sub Parse_data()
'pctarfand.ir & tarfandha.blog.ir'
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:C1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

در کد فوق:

در قسمت vcol =1، عدد جلوی = نشان‌دهنده شماره ستونی است که شما می‌خواهید براساس آن اطلاعات را تفکیک کنید که در مثال ما ستون شماره ۱ است.

در قسمت (“Set ws = Sheets(“Sheet1، عبارت بین دو ” “ نشان‌دهنده نام کاربرگی (شیت) است که شما می‌خواهید اطلاعات آن را تفکیک کنید که در مثال ما Sheet1 است.

در قسمت “title = “A1:C1، عبارت بین دو ” ” نشان‌دهنده محدوده عنوان ستون‌ها است که در مثال ما ردیف اول یعنی A1:C1 است.

پس از اصلاح موارد فوق می‌توانید کد ماکرو را اجرا کنید، برای اینکار دکمه یا کلید F5 را فشار دهید تا کد اجرا شود. نتیجه زیر حاصل می‌شود.

کدهای دیگر:

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

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

Sub Split_Data_Into_Multiple_Worksheets()
'pctarfand.ir & tarfandha.blog.ir'
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As Range 'String
Dim titlerow As Integer
Dim lngLastCol As Long
Dim strLastCol As String
vcol = Application.InputBox("Enter the column number used for splitting", "Select column", 1, , , , , 1)
   If vcol = 0 Then Exit Sub
Set ws = ActiveWorkbook.ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
'new
lngLastColumn = Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
strLastCol = Split(Cells(1, lngLastColumn).Address, "$")(1)
'title = "A1:L1" 'HARD CODED. Should be DYNAMIC
Set title = Application.InputBox("Please enter the Title range", "Select Title Range", "A1:" & strLastCol & "1", Type:=8)
If title Is Nothing Then Exit Sub
'titlerow = ws.Range(title).Cells(1).Row
titlerow = title.Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
'ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
ws.Range(title.Rows(1).Address).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
'Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub