Jump to content
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


Go to solution Solved by سليم حاصبيا,

Recommended Posts

السلام عليكم

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

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

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

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

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

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

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

Link to post
Share on other sites

جرب هذا الكود

تم تغيير اسم الورقة الاخير ة الى "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
Link to post
Share on other sites

السلام عليكم

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

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

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

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

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

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

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

Link to post
Share on other sites
  • Solution

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

الاعمدة حيث كلمات معلومة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
Link to post
Share on other sites

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

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

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

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

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

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

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

Link to post
Share on other sites
Posted (edited)

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

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

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

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

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

Edited by مصطفى محمود مصطفى
  • Like 1
Link to post
Share on other sites

Join the conversation

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

Guest
Reply to this topic...

×   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.

  • Recently Browsing   0 members

    No registered users viewing this page.

×
×
  • Create New...