ترحيل من وقة عمل لأخرى مع استثناء القيم الصفرية

[أحمد عياد - أبو علي]

الإخوة الافاضل:

أرجو مساعدتي في إيجاد حل للملف المرفق، حيث أني اريد ترحيل البيانات من sheet1 الى sheet2 بحيث تكون مرتبة في أعمدة محددة حسب المثال الموضح في sheet2، مع إستثناء القيم الصفرية (لا يتم ترحيلها)

 

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

Transfer data.rar

[أحمد عياد - أبو علي]

السلام عليكم جميعا:

الاخوة الخبراء :

ألا يوجد حل لهذا الموضوع؟ أرجو المساعدة،فأنا في أمس الحاجة الى حل...

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

[أبوعيد]

وعليكم السلام

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

أخي وكما هو معمول به وحسب التعليمات الرجاء تغيير اسم ظهورك إلى اللغة العربية فضلا لا أمرا

 

يوجد حل إن شاء الله ولكن لكثرة انشغال الأعضاء يمكن أن موضوعك لم ينتبه له أحد 

الرجاء المعذرة وطول بالك

تفضل جرب هذا الحل

افتح شيت 2 ثم اضغط transfer

Transfer data1.rar

[أحمد عياد - أبو علي]

21 ساعات مضت, أبوعيد said:

وعليكم السلام

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

أخي وكما هو معمول به وحسب التعليمات الرجاء تغيير اسم ظهورك إلى اللغة العربية فضلا لا أمرا

 

يوجد حل إن شاء الله ولكن لكثرة انشغال الأعضاء يمكن أن موضوعك لم ينتبه له أحد 

الرجاء المعذرة وطول بالك

تفضل جرب هذا الحل

افتح شيت 2 ثم اضغط transfer

Transfer data1.rar

جزاك الله خير اخي بخصوص التوضيح بالنسبة لإسم الظهور...

وبخصوص الملف المرفق فلا يوجد به شيء، فهو كما هو، ليس به حل...

[أبوعيد]

عفوا أخي كلامك صحيح أخطأت في إرفاق الملف

قم بتمكين وحدات الماكرو

افتح شيت2

اضغط transfer

 

Transfer data2.rar

[ياسر خليل أبو البراء]

بارك الله فيك وجزاك الله خيراً أخي الحبيب أبو عيد

متميز كالعادة .. أنت متمكن في الحلقات التكرارية بشكل كبير جداً ..

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

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

 

[أحمد عياد - أبو علي]

جزاك الله خيرا أخي ابو عيد وبارك الله بك...

[ياسر خليل أبو البراء]

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

إليك الكود التالي يوضع في موديول عادي

Sub TransferUsingArrays()
    Dim a, aOutput, iCol As Long, iRow As Long, iLooper As Long
    
    With Worksheets("Sheet1")
        a = .Range("A1").CurrentRegion
    End With
    
    ReDim aOutput(1 To UBound(a) * UBound(a, 2), 1 To 12)
    
    For iCol = 2 To UBound(a, 2)
        For iRow = 2 To UBound(a)
            If a(iRow, iCol) > 0 Then
                iLooper = iLooper + 1
                aOutput(iLooper, 1) = iCol - 1
                aOutput(iLooper, 3) = a(1, iCol)
                aOutput(iLooper, 9) = a(iRow, 1)
                aOutput(iLooper, 12) = a(iRow, iCol)
            End If
        Next iRow
    Next iCol
    
    Sheet2.Cells(2, "A").Resize(iLooper, 12) = aOutput
End Sub

اضغط من لوحة المفاتيح Alt + F8 هيظهر لك نافذة الماكروهات الموجودة لديك اختر الماكرو المسمى TransferUsingArrays وانقر على Run ولاحظ سرعة التنفيذ ..

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

تقبل تحياتي

 

 

Transfer Data YasserKhalil.rar

[أحمد عياد - أبو علي]

38 دقائق مضت, ياسر خليل أبو البراء said:

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

إليك الكود التالي يوضع في موديول عادي

Sub TransferUsingArrays()
    Dim a, aOutput, iCol As Long, iRow As Long, iLooper As Long
    
    With Worksheets("Sheet1")
        a = .Range("A1").CurrentRegion
    End With
    
    ReDim aOutput(1 To UBound(a) * UBound(a, 2), 1 To 12)
    
    For iCol = 2 To UBound(a, 2)
        For iRow = 2 To UBound(a)
            If a(iRow, iCol) > 0 Then
                iLooper = iLooper + 1
                aOutput(iLooper, 1) = iCol - 1
                aOutput(iLooper, 3) = a(1, iCol)
                aOutput(iLooper, 9) = a(iRow, 1)
                aOutput(iLooper, 12) = a(iRow, iCol)
            End If
        Next iRow
    Next iCol
    
    Sheet2.Cells(2, "A").Resize(iLooper, 12) = aOutput
End Sub

اضغط من لوحة المفاتيح Alt + F8 هيظهر لك نافذة الماكروهات الموجودة لديك اختر الماكرو المسمى TransferUsingArrays وانقر على Run ولاحظ سرعة التنفيذ ..

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

تقبل تحياتي

 

 

Transfer Data YasserKhalil.rar

جزاك الله خيرا أخي ياسر وبارك الله بك...

[ياسر خليل أبو البراء]

وجزيت خيراً بمثل ما دعوت لي أخي الحبيب وزيادة

والحمد لله أن تم المطلوب على خير

تقبل تحياتي

[أحمد عياد - أبو علي]

جزاكم الله خيرا جميعا...

استكمالا للموضوع، هل من الممكن ان يتم حذف الاعمدة التي تحتوي على القيم الصفرية (الخالية من أرقام اكبر من 0) في sheet1  قبل البدء بعملية الترحيل الى sheet2؟ كذلك هل ممكن ان يتم دمج خلايا كل رقم في  العمود C الشيت الثانية sheet2 بحيث تصبح خلية واحدة مدمجة تحتوي على رقم الزبون؟

مثال على الدمج في المرفق

وبارك الله بكم

Transfer data 123.rar

[ياسر خليل أبو البراء]

أخي الكريم

أقترح طرح موضوع جديد بطلبك حتى تجد استجابة اسرع من إخوانك

تقبل تحياتي