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

[AL_AYMAN]

السادة الزملاء

سلام الله عليكم 

عندى  فولدر به ملف اكسل اسمه ALL ويوجد26 ملف اكسل اخر فى كل ملف اكسل 14 ورقة عمل  وهذه الاوراق مكررة فى جميع الملفات وبنفس الاسم الذى يختلف هو اسم الملف فقط والبيانات التى توجد فية 

ونفس اوراق العمل هذه توجد فى ملف ALL 

اريد ترحيل كل اوراق العمل من 26 ملف والتى لها نفس الاسم فى جميع الملفات الى ملف ALL  تحت بعض كل 

بدون تكرار اول صف فى كل ورقة عمل لان اول صف يكون راس لكل عمود

لان تجميع هذه الملفات بالطريقة العادية تستغرق وقت ومجهود غير عادى وعرضة للخطأ

فانا فعلا محتاج لحل هذه المشكلة والتى ان شاء الله سأجدها معكم كما تعودت منكم

ومرفق نموذج من هذه الملفات

 

وجزاكم الله خير

Data file.rar

[طارق محمود]

السلام عليكم

 

أخي الكريم

بالمرفق محاولة مبدئية لضيق الوقت

وضعت بيانات وهمية في الـ 26 ملف  (RAND)

الكود مؤقتا يعتمد علي أن الملفات كلها إسمها Data file n.xls

والبيانات في كل شيت 10 أسطر فقط

 

تفضل

 

Data file.rar

[AL_AYMAN]

اخى الكريم 

سلام الله عليك 

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

ثانيا لى بعض الملاحظات والاستفسارات

1- الملف الذى ارسلتة لى يعمل جيدا ولكن عند وضع الكود فى الملف الخاص بى لا يعمل يعطى لى رسالة تفيد بحفظ الملف ثم يغلق الملف

2-هل عند تغيير اسماء الملفات لن يعمل الكود لان الملفات عندى باسم كل محافظة فى مصر لان لنا فروع فى كل المحافظات

3-هل ترتيب اوراق العمل ضرورى ام ان الترحيل يحدث على اسم ورقة العمل

4-عند زيادة او نقصان اوراق العمل هل ستحدث مشكلة 

5-هل يمكن ان يتم وضع اسم الملف فى اخر عمود بالبيانات التى تم ترحيلها من هذ الملف حتى نستطيع ان نفرق بين بيانات كل فرع 

6-هل ممكن ان يكون الترحيل فى اول صف فارغ لتكون البيانات تحت بعض مباشرة وعدم نقل رؤس الاعمدة من كل ورقة 

اخى الكريم ارجو الا اكون قد اطلت عليك ولكنى اريد ان اتعلم وجزاك الله خير

ومرفق ملف به بعض اسماء الفروع لاننى لم استطيع ارفاق جميع الملفات

Data file.rar

[AL_AYMAN]

اخى الكريم 

انا فى انتظار ردك على وقد ارفقت لك نموذج من الملفات

وجزاك الله خيرا

http://www.mediafire.com/download/1qdwog0r0r7ak9n/Data_file.rar

[AL_AYMAN]

اخوانى الكرام

اريد حل لهذه المشكلة ضرورى جدا

وانا فى انتظاركم

وشكرا

[طارق محمود]

السلام عليكم

أخي العزيز

 

تفضل المجلد وبه الملف ALL.xlsm 

وباقي الملفات

إفتح الملف أولا وقبل ضغط الزر راجع صفحاته (كلها فارغة)

ثم إضغط الزر 

 

كان الأسهل أن أضع عنوان المحافظة أعلي بياناتها ولم أنتبه لطلبك أن تكون بجوار البيانات

عموما تصليحها سهل (ولكن سيأخذ بعض الوقت)

لو يناسبك الشكل الحالي ، خلاص

وإلا سوف اصلحها فيما بعد

Data file2.rar

[الـعيدروس]

السلام عليكم

اكيد حل الاستاذ طارق محمود

مابعده كلام

ولاكن قد عملت على الملف

ارفق الكود 

مدى النسخ واحد 

Public Sub Ali_Rn()
Dim W As Workbook
Dim Sh As Worksheet
Dim Path$, My_F$
Dim Rng As Range
    Nm = ThisWorkbook.Name
    Path = ThisWorkbook.Path & Application.PathSeparator
    My_F = Dir(Path & "*.xlsx")
    On Error Resume Next
    Do While My_F <> ""
        If Not My_F = Nm Then
            Workbooks.Open Filename:=Path & "\" & My_F
            Set W = Workbooks(My_F)
            For Each Sh In W.Worksheets
                With Sh
                    SPd False
                    Set Rng = .Range(.Cells(2, 1), .Cells(500, 15))
                    Rng.Copy
                    With Workbooks(Nm).Worksheets(.Name)
                        Lc = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                        .Range("A" & Lc).PasteSpecial xlPasteValues
                    End With
                End With
            Next
            W.Close 0
            SPd True
        End If
        My_F = Dir
    Loop
End Sub


Private Function SPd(Bn As Boolean)
    With Application
        .Calculation = IIf(Bn, -4105, -4135)
        .EnableEvents = Bn
        .ScreenUpdating = Bn
        .DisplayAlerts = Bn
    End With
End Function

[طارق محمود]

جميل أخي / عباد

نفس الفكرة تقريبا

أنا فقط اضفت أن جعلته يأخذ حتي آخر خلية بالصفحة

Sub Collect_Data()
    Application.ScreenUpdating = False
    
    Dim L_Cl As Range, n_Rg As Range
    fN = ActiveWorkbook.Name
    pt = ActiveWorkbook.Path & "\"
    On Error Resume Next
      NextFile = Dir(pt)
        Do While NextFile <> ""
        If NextFile = fN Then GoTo 10
            Workbooks.Open Filename:=NextFile
                For i = 1 To Sheets.Count
                    Sheets(i).Activate
                        shN = Sheets(i).Name
                        Set L_Cl = Cells.SpecialCells(xlCellTypeLastCell)
                            With Workbooks(fN).Sheets(shN)
                                LR = .[A99999].End(xlUp).Row + 2
                                With .Cells(LR, 1)
                                    .Font.Bold = True
                                    .Font.Size = 14
                                    .Interior.ColorIndex = 3
                                    .Value = NextFile
                                End With
                                Set n_Rg = .Cells((LR + 1), 1)
                            End With
                        Range("A1", L_Cl).Copy n_Rg
                Next i
            ActiveWindow.Close
        Application.ScreenUpdating = True
        Application.ScreenUpdating = False
10           NextFile = Dir()
        Loop
    Application.ScreenUpdating = True
End Sub

[AL_AYMAN]

اخوانى الكرام

سلام الله عليكم

اولا اشكركم شكرا جزيلا على اهتمامكم بحل مشكلتى

وجزاكم الله خيرا

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

عمل باسم المحافظة فقط ولا يتم ترحيل بيانات

 

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

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

ومع كل هذا فانا شاكر لكم ولا اعرف فمن الممكن ان يكون الخطأمنى أنا وليس انتم

 

والذى افعلة هو كما قال اخى طارق أتأكد من ان جميع الملفات فارغ ثم اضغط على الزر

 

وافعل فى كود اخى عباد

افتح VBA   ثم اقوم بعمل New Module  واقوم بنسخ الكود فية ثم اقوم بتشغيلة

هذا ما افعلة

اسف جدا ولكن هذا الموضوع مهم جدا بالنسبة لى لاننى افعلة يدويا ويحتاج منى 48 ساعة عمل وعرضة للخطأ

فارجو منكم ان يتسع صدركم لى ولامكانياتى المتواضعة وكثرة اسئلتى

وجزاكم الله كل الخير

[طارق محمود]

الملف اللي أنا أرسلته

لازم تفك الضغط أولا

فتتكون الملفات كلها في فولدر ومن هذا الفولدر تبدأ العمل

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم اخى طارق

عمل  قيم جدا اجدا

جزالك الله خيرا

[AL_AYMAN]

اخوانى الكرام

الاستاذ طارق محمود  والاستاذ عباد

سلام الله عليكم

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

ولكن شىء مهم جدا وهو

1-ان يتم كتابة اسم الملف بجوار البيانات الخاصة فى اخر عمود بجوار البيانات حتى استطيع العمل على الملف وافرق بين بيانات كل فرع

2-ان البيانات لا ترحل كاملة بالعرض اى اذا كان مدى البيانات الى AA2  او اكثر

وللعلم ان البيانات التى اقوم بترحيلها كبيرة جدا اى من الممكن ان يكون الشيت به 30,000 صف او اكثر وحوالى 30 عمود

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

اشكركم جدا جدا جدا على تجاوبكم معى فى حل مشكلتى وفى اننى اتعلم منكم جميعا كل من فى هذا المنتدى الرائع

فى انتظار هذا التعديل

وجزاكم الله كل الخير

[AL_AYMAN]

اخوانى الكرام

الاستاذ طارق محمود  والاستاذ عباد

سلام الله عليكم

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

فانا اسف جدا على كثرة اسئلتى

فان الكود يعمل وتسلم اياديكم على هذا المجهود الرائع

ولا يتبقى الا النقاط التى ذكرتها سابقا

واشكركم جدا لمساعدتكم لى

[الـعيدروس]

كم عدد الأعمدة المراد ترحيلها كعدد ثابت لجميع الأوراق ؟

حسب ملفك الاصلي

[AL_AYMAN]

اولا اشكرك اخى لسرعة ردك على مشكلتى

 ثانيا عدد الاعمده بحد اقصى 35 عمود لان  عدد الاعمدة فى الاوراق مختلف

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

وجزاك الله خيرا

[الـعيدروس]

السلام عليكم

جرب هذا التعديل

لو تنضم الجدول في كافة الاوراق افضل

مثل روؤس الاعمدة تكون ثابته في كافة الأوراق بين الملف

لاني محدد جلب البيانات في الكود من السطر الثاني الى اخر صف

وبلاحظ وجود روؤس اعمدة في البيانات  

بمعنى السطر الاول عناوين وما يليه البيانات

كي يعمل معك الكود بصورة صحيحة

Public S As String
Public Sub Ali_Rn()
Dim W As Workbook, Wr As Workbook
Dim Sh As Worksheet
Dim Path$, My_F$, A_Num, i%, Lc&, L_A&, C
Dim Rng As Range
Dim A_Lst As Range
SPd False
Ali_Clr
On Error Resume Next
Set Wr = ThisWorkbook
    Path = ThisWorkbook.Path & Application.PathSeparator
    My_F = Dir(Path & "*.xlsx")
    Do While My_F <> ""
        If Not My_F = Nm Then
            Workbooks.Open Filename:=Path & "\" & My_F
            Set W = Workbooks(My_F)
            For Each Sh In W.Worksheets
                With Sh
                 SPd False
                 Set Rng = .Range(.Cells(2, 1), .Cells(500, 35))
                 With Rng
                       S = Replace(W.Name, ".xlsx", "")
                       Set A_Lst = .Cells(2, .Columns.Count).End(xlToLeft)
                        A_Num = A_Lst.Column
                 End With
                 L_A = .Cells(.Rows.Count, "A").End(xlUp).Row
               With Wr.Worksheets(.Name)
                 Lc = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                        For C = 1 To A_Num
                           For i = 2 To L_A
                             .Range("A" & Lc - 1).Cells(i, C).Value = Sh.Cells(i, C).Value
                             .Range("A" & Lc - 1).Cells(i, A_Num + 1).Value = S
                           Next i
                        Next
               End With
             End With
             A_Num = 0: R_Num = 0
             Next
             W.Close 0
             SPd True
        End If
        My_F = Dir
    Loop
SPd True
End Sub
Private Function SPd(Bn As Boolean)
With Application
 .Calculation = IIf(Bn, -4105, -4135)
  .EnableEvents = Bn
  .ScreenUpdating = Bn
 .DisplayAlerts = Bn
End With
End Function
Private Sub Ali_Clr()
Dim Dh As Worksheet
 For Each Dh In ThisWorkbook.Worksheets
     Dh.UsedRange.Cells.ClearContents
 Next
End Sub

[AL_AYMAN]

استاذى الكريم

تسلم ايدك على هذا العمل الرائع

ولا اعرف كيف اشكرك على استجابتك

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

ويعطى رسال محتواها

Run time error'6

overflow

وعند الضغط على Debug

ويتم تحديد For i = 2 To L_A  فى الكود من خلال رسالة توقف الكود

وايضا تم وضع اسم الملف بجانب البيانات ولكن يتم وضع اسم ورقة العمل فى نفس الالعمود مع اسم الملف

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

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

وهو كل الملفات واوراق العمل تبدا من الصف الثانى

وكل اوراق العمل بكل الملفات بنفس الاسم ونفس الترتيب

وشكرا جزيلا

[الـعيدروس]

 

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

ويعطى رسال محتواها

Run time error'6

overflow

 

عندي شغال الكود شاهد المرفق

 

 

هل من الممكن ان ياتى باسم الملف فقط

 

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

كود.rar

[AL_AYMAN]

الكود شغال والارقام صحيحة 100% وربنا يكرمك

 

وارجو ان يتسع صدرك لى وانا اعرف انى اثقلت عليك باسئلتى وبضعف خبرتى

ولكن ممكن حضرتك تتاكد من شيت اسمة ( المبيعات اليومية بالتفصيل ) هل يتم الترحيل فيه هل  يوجد فية اى بيانات

لان كل اوراق العمل يتم ترحيلها بنجاح الا هذا الشيت يكون فارغ لا يوجد فيه اى شىء

ولا اعرف السبب حتى اننى غيرت الملف الاساسى وعملت ملف جديد ولكن ظلت هذه المشكلة

ان شاء الله بهذه النقطة نكون قد انتهينا من هذه المشكلة التى ارهقتك بها وازعجتك بها كثيرا

وانا اسف جدا

وشكرا

[الـعيدروس]

لم يرحلها شيء لإن العمود الأول فارغ ؟

والكود بيأخذ اخر صف به بيانات من العمود الأول

جرب التعديل التالي

Public S As String
Public Sub Ali_Rn()
Dim W As Workbook, Wr As Workbook
Dim Sh As Worksheet
Dim iC, Sn$
Dim Shet As Worksheet
Dim Path$, My_F$, A_Num, i%, Lc&, L_A&, C
Dim Rng As Range
Dim A_Lst As Range
SPd False
Ali_Clr
Sn = "المبيعات اليومية بالتفصيل"
On Error Resume Next
Set Wr = ThisWorkbook
    Path = ThisWorkbook.Path & Application.PathSeparator
    My_F = Dir(Path & "*.xlsx")
    Do While My_F <> ""
        If Not My_F = Wr.Name Then
            Workbooks.Open Filename:=Path & "\" & My_F
            Set W = Workbooks(My_F)
            For Each Sh In W.Worksheets
                With Sh
                 SPd False
                 Set Rng = .Range(.Cells(2, 1), .Cells(500, 35))
                 With Rng
                       S = Replace(W.Name, ".xlsx", "")
                       Set A_Lst = .Cells(2, .Columns.Count).End(xlToLeft)
                        A_Num = A_Lst.Column
                 End With
                 If Sh.Name = Sn Then iC = 2 Else iC = 1
                 L_A = .Cells(.Rows.Count, iC).End(xlUp).Row
                 Set Shet = Wr.Worksheets(.Name)
               With Wr.Worksheets(.Name)
                 Lc = .Cells(.Rows.Count, iC).End(xlUp).Offset(1, 0).Row
                        For C = 1 To A_Num
                           For i = 2 To L_A
                             .Range("A" & Lc - 1).Cells(i, C).Value = Sh.Cells(i, C).Value
                             .Range("A" & Lc - 1).Cells(i, A_Num + 1).Value = S
                           Next i
                        Next
               End With
             End With
             A_Num = 0: R_Num = 0
             Next
             W.Close 0
             SPd True
        End If
        My_F = Dir
    Loop
SPd True
End Sub
Private Function SPd(Bn As Boolean)
With Application
 .Calculation = IIf(Bn, -4105, -4135)
  .EnableEvents = Bn
  .ScreenUpdating = Bn
 .DisplayAlerts = Bn
End With
End Function
Private Sub Ali_Clr()
Dim Dh As Worksheet
 For Each Dh In ThisWorkbook.Worksheets
     Dh.UsedRange.Cells.ClearContents
 Next
End Sub

ولا عليك نحنو بالخدمه لاتتردد بأي سؤال

[AL_AYMAN]

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

انا لا اجد كلام اشكرك به

ويكفى انك قد استحملتنى فى كثرة اسئلتى التى تنم عن ضعف خبرتى ومع ذلك فقط صبرت

معى على حل مشكلتى التى ستساعدنى كثيرا بدرجه لا تتخيلها

وبفضل الله الكود يعمل وبصورة ممتازة واكثر من ممتازة وهذا ما كنت اريده بالضبط

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

اشكرك اشكرك اشكرك

وربنا يتقبل منى دعائى  الذى ادعو به لك بظهر الغيب

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

اشكرك واشكر هذا المنتدى المحترم واشكر الاستاذ طارق محمود لانه شارك فى حل هذه المشكلة

اشكرك اشكرك اشكرك اشكرك اشكرك اشكرك وجزاك الله كل الخير

[AL_AYMAN]

استاذى الحبيب العيدروس

ارجو من الله ان تكون فى احسن حال ولى استفسار بسيط 

الكود يعمل معى وبشكل ممتاز ولكن هناك شىء بسيط جدا منذ عمل الكود  ولم اريد ان اثقل عليك بالاسئلة اكثر من ذلك 

لانى كانت اسئلتى وطلباتى كثيرة  

فارجوا ان يتسع صدركم لى فى طلبى هذا

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

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

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

وجزاكم الله خير

[AL_AYMAN]

استاذى الحبيب العيدروس

ارجو من الله ان تكون فى احسن حال ولى استفسار بسيط 

الكود يعمل معى وبشكل ممتاز ولكن هناك شىء بسيط جدا منذ عمل الكود  ولم اريد ان اثقل عليك بالاسئلة اكثر من ذلك 

لانى كانت اسئلتى وطلباتى كثيرة  

فارجوا ان يتسع صدركم لى فى طلبى هذا

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

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

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

وفى انتظار ردكم

وجزاكم الله خير