ترحيل البيانات حسب الحروف الهجائية تحت بعض مع المسلسل في اول عمود

[مصطفى محمود مصطفى]

السلام عليكم

لدي ملف به قاعدة بيانات كبيرة وقام الاخ سليم جزاه الله خيرا بترحيل البيانات حسب القيود وهذا نحتفظ به ورقيا داخل كل قيد

واحيانا نحتاج البيانات حسب الحروف الهجائية عند البحث عن اسم احد الطلبة ورقيا بدل البحث عن جميع الاسماء

ولدي كود للاستاذ الخالدي جزاه الله خيرا ولكن لم استطع اجعله يعمل جيدا وكذلك يرحل على التوالي لثمان اعمدة متتالية في قاعدة البيانات

ارجو التفضل بكود ترحيل حسب الحروف الهجائية من الصف الحادي عشر 11  والتي تبدأ منC11 الى H11  يلحقها على التوالي عمودين متباعدين عن بعضهما البعض فاسم الام في العمود O و موقفه الحالي في العمود AJ ارجو التعديل على الكود او اي كود اخر يقوم بالعمل المطلوب

ولكم وافر الاحترام

الملف لا يقبل التحميل امتداد اكسل حملته WinRAR

ترحيل البيانات حسب الحروف.rar

[سليم حاصبيا]

جرب هذا الكود

تم تغيير اسم الورقة الاخير ة الى "All_In Order"

Option Explicit
Sub Salim_Code()
'كود الاستاذ الخالدي ترحيل البيانات حسب الحروف الهجائية
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim All As Worksheet
Dim Source_sh As Worksheet
Set All = Sheets("All_In Order"): Set Source_sh = Sheets("data1")
Dim RgD As Range, c As Range
Dim st$, t$, Mon_array()
Dim m%, lr%, lrc%, Er%, lc%, lastRo_data1%
lastRo_data1 = Source_sh.Cells(Rows.Count, "D").End(3).Row
 If lastRo_data1 <= 3 Then Exit Sub
Set RgD = Source_sh.Range("D4:D" & lastRo_data1)
Mon_array = Array("ا", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", _
    "ر", "ز", "س", "ش", "ص", "ض", "ط", "ظ", "ع", "غ", "ف", _
    "ق", "ك", "ل", "م", "ن", "ه", "و", "ي")
With All

.Range("B5").Resize(9999, 11 * 28).ClearContents
 For Each c In RgD
    t = Mid(Trim(c), 1, 1)
    st = Left(t, 1)
    If st = "أ" Or st = "آ" Or st = "إ" Then st = "ا"
    m = Application.Match(t, Mon_array, 0)
    If Not IsError(m) Then
        lc = (m - 1) * 11 + 3
        lr = Application.Max(5, .Cells(Rows.Count, lc).End(xlUp).Row + 1)
        .Cells(lr, lc - 1).Value = lr - 4
        .Cells(lr, lc).Resize(1, 8).Value = c.Resize(1, 8).Value
    Else: Er = Er + 1: End If
Next
.Columns.AutoFit
.Range("a1").ColumnWidth = 22
End With
MsgBox "تم بحمد الله" & IIf(Er > 0, vbCr & Application.Rept("=", 30) & vbCr & "عدد الاسماء الخطا غير المرحلة" & vbCr & Er, "")
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

tarhil_by_lettrs.xlsb

[مصطفى محمود مصطفى]

السلام عليكم

اخي الاستاذ سليم حاصبيا وفقكم الله وحفظكم

اكواد رائعة الترحيل واستدعاء البيانات حسب الحرف من القائمة المنسدلة عمل رائع جعله الله في ميزان حسناتكم

هل ممكن التعديل على الكود بان يرحل العمودين اسم الام في عمود O وموقفه الحالي في عمود AJ 

لان هذا الكود يرحل ثمان اعمدة متتالية فانا ارغب بترحيل العمودين بعد الستة اعمدة

وكذلك الستة اعمدة لم يرحل صفحة القيد ولا رقم القيد وهذا مهم لان على اساس رقم القيد وصفحته نستدل لاستخراج اسمه في قيود مدرستنا الورقية

البيانات التي عنوانها باللون الاصفر في ورقة data هي المطلوب ترحيلها

لكم وافر احترامي

[سليم حاصبيا]

تم العديل على الماكرو ليتناسب مع ما تريد

الاعمدة حيث كلمات معلومة1 /معلومة 2   الخ... (يجب اخفائها من أجل ملاحظة البيانات جيداً)

يمكنك اظهارها اذا كانت ضرورية

حجم الملف كبير جداً (حوالي 16 ميغا مضغوطاً) لذلك لم استطع رفعه

فقط ادرج هذا الكود في ملف  تجريبي (نسخة ثانية من نفس الملف) عندك وقم بتجربته (اشدد على  النسخة الاحتياطية ربما كان هناك اخطاء و كما تعرف لا يمكن التراجع (Undo) بعد تنفيذ   الماكرو)

Option Explicit
Sub Salim_Code()
        Rem Created By Salim Hasbaya On 21/3/2020
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim All As Worksheet
Dim Source_sh As Worksheet
Set All = Sheets("All_In Order"): Set Source_sh = Sheets("data1")
Dim RgD As Range, c As Range
Dim st$, t$, Mon_array()
Dim m%, lr%, lrc%, Er%, lc%, lastRo_data1%
lastRo_data1 = Source_sh.Cells(Rows.Count, "D").End(3).Row
 If lastRo_data1 <= 3 Then Exit Sub
Set RgD = Source_sh.Range("D4:D" & lastRo_data1)
Mon_array = Array("ا", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", _
    "ر", "ز", "س", "ش", "ص", "ض", "ط", "ظ", "ع", "غ", "ف", _
    "ق", "ك", "ل", "م", "ن", "ه", "و", "ي")
With All

.Range("B5").Resize(9999, 11 * 28).ClearContents
 For Each c In RgD
    t = Mid(Trim(c), 1, 1)
    st = Left(t, 1)
    If st = "أ" Or st = "آ" Or st = "إ" Then st = "ا"
    m = Application.Match(t, Mon_array, 0)
    If Not IsError(m) Then
        lc = (m - 1) * 11 + 3
        lr = Application.Max(5, .Cells(Rows.Count, lc).End(xlUp).Row + 1)
        .Cells(lr, lc - 1).Value = lr - 4
        .Cells(lr, lc).Resize(1, 7).Value = _
          c.Offset(, -2).Resize(1, 7).Value
        .Cells(lr, lc + 7).Value = Source_sh.Cells(c.Row, "o")
        .Cells(lr, lc + 8).Value = Source_sh.Cells(c.Row, "AJ")
    Else: Er = Er + 1: End If
Next
.Columns.AutoFit
.Range("a1").ColumnWidth = 22
End With
MsgBox "تم بحمد الله" & IIf(Er > 0, vbCr & Application.Rept("=", 30) & vbCr & "عدد الاسماء الخطا غير المرحلة" & vbCr & Er, "")
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

 

[مصطفى محمود مصطفى]

الاستاذ الكبير سليم حاصبيا وفقكم الله وانعم عليكم بالصحة والعافية

كود وتعديل اكثر من رائع جعله الله سبحانه وتعالى في ميزان حسناتكم

ولو غلبتك معي اود ان يكون الترحيل من السطر 11 لان قاعدة البيانات التي اعمل عليها كما قلت لكم سابقا جعلتها من السطر 11

انا غيرت في هذه الجزئية من الكود  هل صحيح لان الان يعمل بشكل صحيح خوفا من المستقبل يكون خلل

Set RgD = Source_sh.Range("D11:D" & lastRo_data1)

ودعواتي لكم بدوام الموفقية والنجاح

ترحيل البيانات حسب الحروف الهجائية .xlsb.xlsm

[سليم حاصبيا]

100%100 True

لكن ادرج ماكرو البحث من خلال الحروف (الازار الحمراء) في صفحة  All in Order وذلك من اجل سرعة التفتيش عن اسماء بحرف معين

[مصطفى محمود مصطفى]

الله يبارك لكم في عافيتكم وصحتكم استاذ سليم

نعم في الملف الذي عندي عملته وكان رائعا ويختصر الكثير من الوقت

يسرت لي الكثير الكثير يسر الله سبحانه وتعالى اموركم واعانكم لفعل الخير

وفقكم الله وزادكم علما ومعرفة

لكم وافر احترامي وتقديري

تم تعديل مارس 21, 2020 بواسطه مصطفى محمود مصطفى