السلام عليكم ورحمة الله وبركاته
كثير منا قد يكون لديه جدول بيانات ، ويوجد عمود معين توجد فيه بيانات ، ويريد أن يقوم بفلترة البيانات حسب كل قيمة موجودة في هذا العمود
مثال ليتضح المقال : بفرض أن لديك قائمة عملاء ، وأسماء العملاء مكررين ، وتريد تصدير بيانات كل عميل إلى مصنف جديد أي بيانات كل عميل تكون في مصنف مستقل
كما تلاحظون في الصورة المطلوب تصدير بيانات العملاء (محمد علي ، وفريد خان ، ومنصور السعيد ، ومنور أمين) كل عميل إلى مصنف مستقل ، ولا يشترط ترتيب البيانات في العمود ... ضع البيانات بأي شكل تريده ، والكود سيعمل بشكل ممتاز ليؤدي المطلوب إن شاء الله
في الكود تقوم بتحديد رقم أول عمود وهو هنا في المثال 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
إعداد / ياسر خليل أبو البراء
اقر انا الموقع ادناه بان الاستاذ : ياسر خليل ( ظاهرة ابداعيه .. تدرس )
ردحذفحسن علي
ربنا يبارك فيك يا قبطان ويجازيك خير
ردحذفنورت المدونة بمرورك الندي
مبدع بحق
ردحذفجزيت خيراً أخي الكريم ، والإبداع أنتم مجشعوه
ردحذفاخى ياسر
ردحذفابداع بسم الله ما شاء الله
جزاكم الله خيراً أخي الكريم سعد عابد ونورت المدونة بتعليقك الجميل
ردحذفروعه
ردحذفجزاك الله خيرا
ردحذفرغم أنى أغبط الاكسل عليك ورجوت لو تحولت للأكسس حتى لو بعض الوقت
محبكم فى الله - أحد أعضاء أوفيسنا
أخي الكريم المراد
ردحذفأخي الكريم السيد
أخي الكريم أبو عبد الله
بارك الله فيكم ونورتم المدونة بمروركم العطر ، والإكسيل والأكسس ولاد عم مبعدناش كتير
تقبلوا تحياتي
بارك الله فيك اخي الكريم ... ورحم الله والديك
ردحذف