السلام عليكم ورحمة الله وبركاته
كثير منا قد يكون لديه جدول بيانات ، ويوجد عمود معين توجد فيه بيانات ، ويريد أن يقوم بفلترة البيانات حسب كل قيمة موجودة في هذا العمود
مثال ليتضح المقال : بفرض أن لديك قائمة عملاء ، وأسماء العملاء مكررين ، وتريد تصدير بيانات كل عميل إلى مصنف جديد أي بيانات كل عميل تكون في مصنف مستقل
كما تلاحظون في الصورة المطلوب تصدير بيانات العملاء (محمد علي ، وفريد خان ، ومنصور السعيد ، ومنور أمين) كل عميل إلى مصنف مستقل ، ولا يشترط ترتيب البيانات في العمود ... ضع البيانات بأي شكل تريده ، والكود سيعمل بشكل ممتاز ليؤدي المطلوب إن شاء الله
في الكود تقوم بتحديد رقم أول عمود وهو هنا في المثال 1 أي العمود A ، كما نقوم بتحديد رقم آخر عمود وهو هنا 4 أي العمود D
كما تقوم بتحديد العمود الذي ستقوم بفلترة البيانات فيه وهو هنا عمود العملاء ألا وهو رقم 1
كما تقوم بتحديد اسم ورقة العمل المطلوب العمل عليها ، وهي ورقة العمل Sheet1
وأخيراً إليكم الكود الذي يؤدي المهمة (تصدير بيانات من نفس القيمة لمصنفات جديدة ، حيث يتم تصدير البيانات في نفس مسار المصنف الحالي في مجلد اسمه Output)
Sub Export_Workbooks_Using_Filter()
'Author : YasserKhalil
'Release : 07 - 09 - 2016
'------------------------
Dim a As Variant
Dim I As Long
Dim P As Integer
Dim cnt As Integer
Dim Dic As Object
Dim strDir As String
Dim Arr() As Double
Dim iFlag As Boolean
'=========================================================
Const firstCol As Long = 1 'First Column
Const lastCol As Long = 4 'Last Column
Const colNo As Long = 1 'Column To Filter
Const sSheet As String = "Sheet1" 'Sheet Name
'=========================================================
strDir = ThisWorkbook.Path & "\Output\"
For P = firstCol To lastCol
ReDim Preserve Arr(P - 1)
Arr(P - 1) = Sheets(sSheet).Columns(P).ColumnWidth
Next P
iFlag = Sheets(sSheet).DisplayRightToLeft
Call SpeedUp
If Dir(strDir, vbDirectory) = "" Then MkDir strDir
Sheets.Add before:=Sheets(1)
Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMOde = 1
With Sheets(sSheet).[A1].CurrentRegion
.Columns(colNo).Value = Application.Trim(.Columns(colNo).Value)
a = .Value
.Parent.AutoFilterMode = False
For I = 2 To UBound(a, 1)
If Not Dic.exists(a(I, colNo)) And Not IsEmpty(a(I, colNo)) Then
Dic(a(I, colNo)) = Empty
.AutoFilter colNo, a(I, colNo)
.Copy Sheets(1).Cells(1)
Sheets(1).Copy
With ActiveWorkbook
With Sheets(1)
.Name = "Sheet1"
.DisplayRightToLeft = iFlag
.Cells(1).CurrentRegion.RowHeight = 19
For cnt = firstCol To lastCol
.Columns(cnt).ColumnWidth = Arr(cnt - 1)
Next cnt
End With
.SaveAs strDir & RemoveSpecial(CStr(a(I, colNo))) & ".xlsx"
.Close
End With
Sheets(1).Cells.Clear
.AutoFilter
End If
Next I
End With
Sheets(1).Delete
Call SpeedDown
MsgBox "Done...", 64
End Sub
Function RemoveSpecial(sInput As String) As String
Dim sSpecialChars As String
Dim I As Long
sSpecialChars = "\/:*?""<>|"
For I = 1 To Len(sSpecialChars)
sInput = VBA.Trim(Replace$(sInput, Mid$(sSpecialChars, I, 1), " "))
Next I
RemoveSpecial = sInput
End Function
Function SpeedUp()
With Application
.Calculation = xlManual
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
End Function
Function SpeedDown()
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Function
إعداد / ياسر خليل أبو البراء
