اذهب الي المحتوي
أوفيسنا

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

السلام عليكم

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

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

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

ارجو التفضل بكود ترحيل حسب الحروف الهجائية من الصف الحادي عشر 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

  • Like 1
رابط هذا التعليق
شارك

السلام عليكم

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

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

هل ممكن التعديل على الكود بان يرحل العمودين اسم الام في عمود 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

 

 

  • Like 1
رابط هذا التعليق
شارك

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

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

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

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

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

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

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

رابط هذا التعليق
شارك

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

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

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

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

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

تم تعديل بواسطه مصطفى محمود مصطفى
  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information