كود استدعاء بيانات من شيتات متعددة

[waleed ahmad muhammad]

السلام عليكم ورحمة الله وبركاته

السادة الزملاء الأفاضل اعضاء المنتدى الموقر

مطلوب كود استدعاء بيانات من شيتات متعددة ثم التعديل عليها ثم ترحيلها مرة أخرى وذلك لأكثر من صف

الملف مرفق

أرجو التكرم بالإفادة 

 

استدعاء من عدة شيتات- .xlsm

[Mohamed Hicham]

لتعديل البيانات لابد من وضع شرط ثابت يمكننا الاعتماد عليه داخل الاكواد  وهدا غير متوفر عندك على الملف بحكم ان البيانات في العمود الاول والثاني  مكررة في عده صفوف 

في وجهة نظري افضل طريقة هي استبدال كود الترحيل والاشتغال على انشاء اوراق عمل بشرط القيم الموجودة في عمود التوجيه مع حدف الاوراق السابقة   بحيث يتم تحديث جميع اوراق العمل سواءا عند اظافة جديدة او تعديل .

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

Sub RefreshData()  
 Dim cUnique     As Collection
    Dim rng         As Range, cRng As Range
    Dim Cell        As Range, LstRow As Long
    Dim W_Name        As Variant, s As String
    Dim worksheetexists As Boolean
    
    Set WS_Data = ThisWorkbook.Sheets("data")        ' الرئيسية
    Set ST2 = ThisWorkbook.Sheets("اليومية")
    Set rng = WS_Data.Range("A3:A" & WS_Data.Cells(WS_Data.Rows.Count, "A").End(xlUp).Row)
    
    Set cUnique = New Collection
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each ws In Sheets
        If ws.Name <> WS_Data.Name And ws.Name <> ST2.Name Then ws.Delete
    Next
    On Error Resume Next
    For Each Cell In rng.Cells
        cUnique.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0
    
    For Each W_Name In cUnique
        s = W_Name
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = W_Name
        ActiveSheet.DisplayRightToLeft = True
        With WS_Data
            LstRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            .Range("A2").AutoFilter Field:=1, Criteria1:=W_Name
            Set cRng = .Range("A2:E" & LstRow)
            cRng.Copy Sheets(s).Range("A2")
            .Select
            .Range("A2").AutoFilter
         ST2.Move After:=Worksheets(Worksheets.Count)
        End With
        For Each ws In Sheets
        If ws.Name <> WS_Data.Name And ws.Name <> ST2.Name Then ws.Columns("A:E").ColumnWidth = 21
    Next
    Next W_Name
        Application.ScreenUpdating = True

 WS_Data.Activate
End Sub

 

 

 

استدعاء من عدة شيتات V2.xlsm

تم تعديل الأربعاء at 20:06 بواسطه Mohamed Hicham

[waleed ahmad muhammad]

جزاك الله خيرا أخي الفاضل أستاذ محمد هشام 

أشكر لك اهتمامك والرد على استفساري 

أشكرك على مجهودك المتميز هذا الكود الذي أرسلته لي 

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

وأن الحسابات والشيتات التي أعمل عليها أكثر من ذلك بكثير وخاصية الحذف التي يقوم بها الكود الذي أرسلته حضرتك لي لا يتناسب مع العمل

في الحسابات لأن الحسابات كلها لابد أن تظل بياناتها متاحة 

والمطلوب بعد استذعاء البيانات في شيت data في تاريخ معين وتعديل بيانات اي بند من بنود الحسابات ثم ترحيلها تذهب هذه البيانات في مكانها بعد التعديل دون حذف لأي بيانات موجودة ولم يتم تعديلها

ولكم جزيل الشكر والتقدير

[Mohamed Hicham]

هناك اخي فكرة اخرى لا اعلم هل تناسيك ام لا هي ان تقوم باظافة عمود لتسلسل البيانات في عمود A بحيث يتم ترقيم البيانات في جميع اوراق العمل  عند الترحيل وبهدا ستحصل على معيار غير مكرر نعتمد عليه بجانب اسم ورقة العمل لتعديل البيانات 

مثال  على ملفك  بعد استدعاء البيانات 

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

 

واخيرا سنقوم بوضع شرط داخل الاكواد ان يتم تعديل الصف اعتمادا على رقم التسلسل واسم ورقة العمل الموجود مسبقا على عمود التوجيه لكي لا تتداخل بيانات الصفوف في ما بعضها 

طبعا هدا  يلزمنا بتعديل جميع الاكواد سواءا الاستدعاء او الترحيل 

في حالة هدا الحل يناسبك ممكن نشتغل عليه اخي الفاضل .

 

[Mohamed Hicham]

تفضل جرب اخي ووافينا بالنتيجة 

 

Sub RefreshData()                   ' تعديل
Dim i As Long, k As Long
Dim last_Dest As Long, lastrow  As Long
Dim ws_data As Worksheet: Set ws_data = Worksheets("data")

For Each ws_dest In ThisWorkbook.Worksheets
lastrow = ws_data.Cells(ws_data.Rows.Count, 1).End(xlUp).row
last_Dest = ws_dest.Cells(ws_dest.Rows.Count, 1).End(xlUp).row
Application.ScreenUpdating = False

For i = 2 To lastrow
    For k = 2 To last_Dest
    
       'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا
 If ws_dest.Name <> ws_data.Name And ws_dest.Name <> "اليومية" And ws_dest.Name <> "ورقة6" Then
 
 
 ' شرط تطابق  عمود التسلسل وعمود التوجيه
        If ws_dest.Cells(k, 1).Value = ws_data.Cells(i, 1).Value And _
           ws_dest.Cells(k, 2).Value = ws_data.Cells(i, 2).Value Then _

'في حالة تحقق الشرط
ws_dest.Cells(k, 3).Value = ws_data.Cells(i, 3).Value    'التاريخ
    ws_dest.Cells(k, 4).Value = ws_data.Cells(i, 4).Value  ' البيان
      ws_dest.Cells(k, 5).Value = ws_data.Cells(i, 5).Value  'مدين
         ws_dest.Cells(k, 6).Value = ws_data.Cells(i, 6).Value  'دائن
 
 ws_dest.Activate
'تسطير تلقائي للبيانات
DL = ws_dest.Range("A65500").End(xlUp).row
    DC = ws_dest.Cells(1, Columns.Count).End(xlToLeft).Column
      ws_dest.Columns("A:F").Borders.LineStyle = xlNone
         ws_dest.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin
                        End If
                    End If
                 Next
             Next
     Next ws_dest
ws_data.Activate

MsgBox "تم التعديل بنجاح", 64

Application.ScreenUpdating = True

End Sub

 

 

Sub transfer_data()                             ' ترحيل
Dim Sh As Worksheet
Dim ws_data As Worksheet: Set ws_data = Worksheets("data")

For Each Sh In ThisWorkbook.Worksheets
For R = 2 To [B20000].End(xlUp).row
If Cells(R, 2).Value = Sh.Name And Cells(R, 2).Value <> Empty Then
Application.ScreenUpdating = False
Cells(R, 2).Resize(1, 5).Copy Sh.Range("B" & Sh.[B20000].End(xlUp).row + 1)

     End If
    Next
Next
For Each Sh In Worksheets
   'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا

  If Sh.Name <> "اليومية" And Sh.Name <> "data" And Sh.Name <> "ورقة6" Then
   Sh.Activate
Sh.Range("A3:A1000").ClearContents
Sh.Range("A3") = 1
Sh.Range("A3:A" & Range("B" & Rows.Count).End(xlUp).row).DataSeries , xlDataSeriesLinear
    DL = Sh.Range("A20000").End(xlUp).row
    DC = Sh.Cells(1, Columns.Count).End(xlToLeft).Column
    Sh.Columns("A:F").Borders.LineStyle = xlNone
    Sh.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin
End If
    Next
MsgBox ("تم بحمد الله ترحيل القيود لا تنسى أن تشكر الله علي هذه النعم "), vbOKOnly + vbInformation, "لاتنسونا من صالح الدعاء لنا ولولدينا وللمسلمين"
ws_data.Activate
Application.ScreenUpdating = True
End Sub

 

 

استدعاء من عدة شيتات- V3.xlsm

[waleed ahmad muhammad]

السلام عليكم ورحمة الله وبركاته

الأخ الفاضل الخلوق أستاذ / محمد هشام 

أسعد الله صباحك بكل خير

أولا أود أن أشكر لك اهتمامك بحل مشكلتي أسأل الله أن يجزيك عني خير الجزاء حضرتك قمت بمجهود رائع وأنجزت لي حل مشكلتي 

شكر الله لك صنيعك وجعله في ميزان حسناتك وأسأل الله أن يحسن إليك كما أحسنت إليّ 

بارك الله فيك وفي علمك وزادك علم وتقدم وابداع 

ثانيا أعتذر لحضرتك على التأخر في الرد نظرا لأن بالأمس الجمعة كنت في إجازة وجهاز الكمبيوتر موجود في الشركة