تعديل كود ترحيل من ملف الى ملف

[عمر الجزاوى]

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

الاستعلام.xlsm العملاء.xlsm

[حسونة حسين]

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

تفضل اخى الكريم

Sub Test()
Dim WB As Workbook, WS As Worksheet, SH As Worksheet, Arr As Variant, Temp As Variant
Dim i As Long, j As Long, p As Long
Set SH = ThisWorkbook.Worksheets("ترحيل يومية")
    Arr = SH.Range("A5:F" & SH.Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "العملاء.xlsm", False)
    For Each WS In WB.Worksheets
        If SH.Range("D2") = WS.Name Then
            For i = 1 To UBound(Arr, 1)
                p = p + 1
                For j = 1 To UBound(Arr, 2)
                    Temp(p, j) = Arr(i, j)
                Next
            Next
        End If
        If p > 0 Then
            WS.Range("H" & WS.Cells(Rows.Count, 8).End(xlUp).Row + 1).Resize(p, UBound(Temp, 2)).Value = Temp
            WS.Range("K7:K" & WS.Cells(Rows.Count, 8).End(xlUp).Row).NumberFormat = "[$-1010000]yyyy/mm/dd;@"
            GoTo 86
        End If
    Next WS
86 WB.Close Savechanges:=True

End Sub

 

[عمر الجزاوى]

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

[حسونة حسين]

آمين يارب العالمين وإياكم 

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

[عمر الجزاوى]

أستاذ حسونة نسخت كود حضرتك حاولت اعدله واطبقه على شيت الفاتورة اللى هيرحل الى شيت القيمة المضافة حسب الشهر علشان ارحل خلايا معينة ولكن لم افلح ممكن بعد اذنك عمل كود يرحلى الخلايا H3 و الخلية F5 والخلية B7 والخلية H25 والخليه H26 والخلية H27 الترحيل يكون حسب الشهر الموجود في الخلية j1  الى شيت القيمة المضافة المقسم الى 12 شهر كل شهر فى شيت وانا اسف على تعب سيادتكم

الاستعلام.xlsm القيمة_المضافة.xlsm

[حسونة حسين]

اخى الكريم عمر 

هذا طلب اخر غير الذي في المشاركه الاولى

اكتب موضوع جديد بالطلب الجديد 

على فكرة المنتدي مش هيدفعك فلوس على الموضوع الجديد 🤗😁

[عمر الجزاوى]

تمام

[عمر الجزاوى]

السلام عليكم ورحمة الله وبركاته أستاذ حسونة انا اسف في تعديل بسيط العمود F الموجود في شيت ترحيل اليوميه عند ترحيل الى شيت العملاء المفروض يرحل في العمود D وشكراعلى حسن تعاونكم

[حسونة حسين]

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

اخى عمر 

ارفق ملف لشكل النتائج المتوقعه

 

 

تم تعديل نوفمبر 30, 2021 بواسطه hassona229

[عمر الجزاوى]

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

[عمر الجزاوى]

للرفع

[عمر الجزاوى]

للرفع

[عمر الجزاوى]

للرفع

[حسونة حسين]

المفروض اخى عمر ان هذا موضوع اخر غير طلبك في المشاركه الاولى 

 

[عمر الجزاوى]

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

[حسونة حسين]

تفضل اخى الكريم 

Option Explicit

Sub Transfer_Non_Adjacent_Columns_Using_Arrays_YasserKhalil_ExcelEgy()
'Code by MR.Yasser Khalil
'From page https://www.excel-egy.com/forum/t3892
    Dim WB As Workbook, WS As Worksheet, SH As Worksheet
    Dim arr As Variant, i As Variant, cr As Variant, j As Long
    Dim LR As Long
    Set SH = ThisWorkbook.Worksheets("ترحيل يومية")
    Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "العملاء.xlsm")
    Set WS = WB.Worksheets(SH.Range("D2").Value)

    arr = SH.Range("A5:F" & SH.Cells(Rows.Count, 1).End(xlUp).Row).Value2
    cr = Array(8, 9, 10, 11, 12, 4)
    LR = WS.Cells(Rows.Count, 11).End(xlUp).Row + 1
    For Each i In Array(1, 2, 3, 4, 5, 6)
        WS.Cells(LR, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i)
        j = j + 1
    Next i
    WS.Range("K:K").NumberFormat = "[$-1010000]yyyy/mm/dd;@"
    WB.Close Savechanges:=True
End Sub

 

[عمر الجزاوى]

والحمد لله أخيراً توصلت للمراد بما قدمته لي من عون ومساعدة فهذا هو ما كنت أحتاج الوصول إليه ويعلم الله كم فرحتي كبيرة وأنا أرى نتائج عملك وجهدك الطيب وبارك الله فيك وفي علمك وعملك ، لك منا كل الثناء والتقدير.. بعدد قطرات المطر.. وألوان الزهر، وشذى العطر.. على جهودك الثمينة والقيمة عبارات الشكر لتخجل منك.. لأنك أكبر منها.. فأنت من حوّلت الفشل إلى نجاح باهر.. يعلو في القمم.. معلمنا الغالي نشكر جهدك.. ونقيّم عملك، فأنت أهل للتميز.. كل عبارات الشكر.. وعطر الورود.. نقدمها لك يا معلمنا الجليل.. يا صاحب الفضل الكبير

[حسونة حسين]

الحمد لله الذي بنعمته تتم الصالحات 

الفضل كله لله اخى عمر

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