ترحيل الصفوف الجديدة التى تم استيفاء بياناتها من ملف لملف اخر

[عادل ابوزيد]

السلام عليكم استاتذتى الافاضل

استكمالاً للموضوع  التالى 

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

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

وتم اختيار ادارة الاحياء .. وسيتم التطبيق على باقى الادارات ) لذلك هناك ملفان ملف خاص بادارة الوارد وملف خاص بادارة الاحياء 

والمطلوب : يتم فتح كلا الملفين وتقوم ادارة الاحياء بتشغيل الملف ونقل الملفات التى تم استكمال العمل بها 

( فى الواقع هو نفس فكرة الملف الاصل والخاص بادارة الوارد ( من شيت لشيت ) اما هنا بين ملف وملف والملف الفرعى وهو الذى يستدعى البيانات 

ارجو اكون قد استطعت توصيل الفكرة

الموضوع الثانى.rar

[عبدالله بشير عبدالله]

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

قم بفتح ملف احياء وشغل الكود  ولا تفتح الملف الرئيسي الكود يقوم بفتحه واغلاقه اثناء تنفيذ الكود

نفس الكود يطبق على الادارات الاخرى 

عند حفظ الملف احقظه xslb او xlsm   لان الملف به كود

مراعاة اسماء الصفحات موحدة بمعنى في الملف الرئيسي احياء يكون في ملف احياء اسم الشيت نفس الاسم 

الملف الرئيسي.xlsb

احياء.xlsb

 

تم تعديل ديسمبر 7 بواسطه عبدالله بشير عبدالله

[محمد هشام.]

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

 يمكنك استخدام الكود التالي من المصنف الرئيسي  وتحديث ملفات الإدارة دفعة واحدة  بدون فتحها او تغيير تنسيقها يكفي وضعها في نفس مسار المصنف 

بحيث يتم تحديث البيانات عند التحقق من عدم وجود الرقم التأميني مسبقا على ملف الإدارة الهدف وتحديث عمود (م)  وإظافة تاريخ التحديث في عمود ( تاريخ دخول القسم)

Option Explicit
Sub Departments_update()

    Dim WB As Workbook, destWB As Workbook, srcWS As Worksheet, destWS As Worksheet, _
    iRow As Long, Rng As Range, dstRng As Long, lastRow As Long, Cnt As String, _
    tmp As String, n As String, WSname As String, ShArr As Variant, j As Boolean, _
    Updated As Boolean, nameFile As String, cell As Range, result As Boolean

    ShArr = Array("المستحقين", "احياء", "التفتيش", "اخرى")
    
    Cnt = "=SUBTOTAL(103,INDIRECT(ADDRESS(ROW(),COLUMN()+1)&"" :""&ADDRESS(ROW($E$7),COLUMN()+1)))"
    Updated = False
    result = False
    
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    Application.EnableEvents = False: Application.DisplayAlerts = False
    Set WB = ThisWorkbook

    For Each srcWS In WB.Worksheets
        If Not IsError(Application.Match(srcWS.Name, ShArr, 0)) Then
            WSname = srcWS.Name
            nameFile = WB.Path & "\" & WSname & ".xls"

            If Dir(nameFile) <> "" Then
                result = True
                Set destWB = Workbooks.Open(nameFile)
                Set destWS = destWB.Worksheets(WSname)

                If Not destWS Is Nothing Then
                    For iRow = 7 To srcWS.Cells(srcWS.Rows.Count, "R").End(xlUp).Row
                        n = srcWS.Cells(iRow, "R").Value
                        If InStr(1, n, WSname, vbTextCompare) > 0 And n <> "" Then
                            tmp = srcWS.Cells(iRow, "E").Value
                            j = False

                            lastRow = destWS.Cells(destWS.Rows.Count, "E").End(xlUp).Row
                            For Each cell In destWS.Range("E7:E" & lastRow)
                                If cell.Value = tmp Then
                                    j = True
                                    Exit For
                                End If
                            Next cell

                            If Not j Then
                                Set Rng = srcWS.Range(srcWS.Cells(iRow, 3), srcWS.Cells(iRow, 27))
                                dstRng = destWS.Cells(destWS.Rows.Count, "E").End(xlUp).Row + 1
                                If dstRng < 7 Then dstRng = 7
                                destWS.Cells(dstRng, "C").Resize(, 25).Value = Rng.Value
                                destWS.Cells(dstRng, "D").Value = Date
                                destWS.Cells(dstRng, "B").Formula = Cnt
                                Updated = True
                            End If
                        End If
                    Next iRow

                    destWB.Close SaveChanges:=True
                Else
                    destWB.Close SaveChanges:=False
                End If
                
                Set destWB = Nothing
                Set destWS = Nothing

            End If
        End If
    Next srcWS

    If result Then
        MsgBox IIf(Updated, "تم تحديث البيانات بنجاح", "جميع البيانات محدثة مسبقا"), vbInformation, "تعليمات"
    Else
        MsgBox "لم يتم العثور على أي ملفات خاصة بالإدارات", vbExclamation, "تنبيه"
    End If

    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True: Application.DisplayAlerts = True
    
    Set WB = Nothing: Set srcWS = Nothing: Set Rng = Nothing: Set cell = Nothing
    
End Sub

 

 

ملفات الإدارة.rar

 

ترحيل الصفوف مع عدم التكرار.rar

تم تعديل ديسمبر 8 بواسطه محمد هشام.

[عادل ابوزيد]

السلام عليكم .. اساتذتنا الافاضل  عبد الله بشير عبد الله ، محمد هشام

ما شاء الله فتح الله عليكم وانعم عليكم وافاض عليكم بنعمه وكرمه 

حلول ولا اروع وكاننى فى بستان تملأه الزهور ولكل زهره رائعة عطره تفوح عطرها لتسعدنا 

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