logo

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
بكار للأبد لا تميز خلال هذه الفترة-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة خطأ برمجي والماكرو لا يعمل run time error 438 اكسيل اسئله واجابات



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




موضوع مغلق


  • تمت الإجابة
06-11-2020 01:26 مساءً
معلومات الكاتب ▼
تاريخ الإنضمام : 23-01-2018
رقم العضوية : 3965
المشاركات : 45
الجنس :
تاريخ الميلاد : 25-10-1981
الدعوات : 1
قوة السمعة : 83
الاعجاب : 0
السلام عليكم من ورحمه الله وبركاته

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

test.xlsmالموضوع مدموج من مواضيع متعدّدة



Please do not upload a file to an external link ... as long as its size is small, the file has been modified and the file is uploaded in the forum
 
 
  test.xlsm   تحميل xlsm مرات التحميل :(10)
الحجم :(10.76) KB





look/images/icons/i1.gif نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق
  06-11-2020 06:11 مساءً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 23-08-2017
رقم العضوية : 69
المشاركات : 164
الجنس :
تاريخ الميلاد : 1-1-1982
الدعوات : 1
قوة السمعة : 867
الاعجاب : 0
جرب الكود
CODE
Sub test()
Dim lr, r, x
r = 4
With Sheets(1)
.Range("d4:e10000").ClearContents
lr = .Cells(Rows.Count, "k").End(3).Row
   For x = 4 To lr
   If .Cells(x, "k") = 0 Then GoTo 1
   .Range("d" & r).Resize(1, 2).Value = .Cells(x, "k").Resize(1, 2).Value
   r = r + 1
1:   Next x
End With
End Sub

أثارت هذه المشاركة إعجاب: YasserKhalil، Dreamier، السعيد الجزائري،



look/images/icons/i1.gif نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق
  07-04-2021 09:39 صباحاً   [2]
معلومات الكاتب ▼
تاريخ الإنضمام : 23-01-2018
رقم العضوية : 3965
المشاركات : 45
الجنس :
تاريخ الميلاد : 25-10-1981
الدعوات : 1
قوة السمعة : 83
الاعجاب : 0
السلام عليكم ورحمه الله وبركاته
طرحت سؤال منذ فتره لنقل بيانات بين عمودين بدون الاخلايا الفارغه وتفضل علينا الاستاذ حسين مامون بوضع كود الحل و الكود بالملف المرفق
فقط ارجو اضافه نقل البيانات بنفس تنسيق العمود الاصلى
وكل عام وانتم بخير بقرب حلول شهر رمضان المبارك اعاده الله علينا بالخير واليمن والباركات

test.xlsm

أثارت هذه المشاركة إعجاب: YasserKhalil،



look/images/icons/i1.gif نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق
  16-04-2021 05:48 مساءً   [3]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10522
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36735
الاعجاب : 177
السلام عليكم
جرب الكود التالي عله يفي بالغرض إن شاء العلي القدير
CODE
Sub Test()
    With Sheets(1).Range("K3").CurrentRegion
        .AutoFilter 1, "<>0"
        .Copy Sheets(1).Range("D3")
        .AutoFilter
    End With
End Sub

أثارت هذه المشاركة إعجاب: ali mohamed ali، Dreamier، السعيد الجزائري،



look/images/icons/i1.gif نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق
  17-04-2021 06:56 صباحاً   [4]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
زيادة في اثراء الموضوع
CODE

Option Explicit

Sub without_zeros()
Dim Source_Array As Variant
Dim Target_Array()
Dim n%, i%
    With Sheets("ورقة1")
      .Range("D3").CurrentRegion.ClearContents
       Source_Array = .Range("K3").CurrentRegion
       
       For i = 1 To UBound(Source_Array)
          If Source_Array(i, 1) <> 0 Then
             n = n + 1
             ReDim Preserve Target_Array(1 To 2, 1 To n)
             Target_Array(1, n) = Source_Array(i, 1)
             Target_Array(2, n) = Source_Array(i, 2)
           End If
        Next i
          
          If n Then
            .Range("D3").Resize(n, 2) = _
             Application.Transpose(Target_Array)
          End If
    End With
End Sub

أثارت هذه المشاركة إعجاب: YasserKhalil، Dreamier، ali mohamed ali، السعيد الجزائري،



look/images/icons/i1.gif نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق
  17-04-2021 01:19 مساءً   [5]
معلومات الكاتب ▼
تاريخ الإنضمام : 23-01-2018
رقم العضوية : 3965
المشاركات : 45
الجنس :
تاريخ الميلاد : 25-10-1981
الدعوات : 1
قوة السمعة : 83
الاعجاب : 0
بارك الله فيك استاذتا الكبير ياسر و تقبل الله صيامكم وقيامكم وصالح أعمالكمبارك الله فيك استاذ سالم و تقبل الله صيامكم وقيامكم وصالح أعمالكم
فقط اتمني اضافه نسخ التنسيق من الجدول الاصلي حتي يصبح الكود مفيد للجميع


المشاركة الأصلية كتبت بواسطة: salim زيادة في اثراء الموضوع
CODE
 Option Explicit Sub without_zeros() Dim Source_Array As Variant Dim Target_Array() Dim n%, i%     With Sheets("ورقة1")       .Range("D3").CurrentRegion.ClearContents        Source_Array = .Range("K3").CurrentRegion                For i = 1 To UBound(Source_Array)           If Source_Array(i, 1) <> 0 Then              n = n + 1              ReDim Preserve Target_Array(1 To 2, 1 To n)              Target_Array(1, n) = Source_Array(i, 1)              Target_Array(2, n) = Source_Array(i, 2)            End If         Next i                      If n Then             .Range("D3").Resize(n, 2) = _              Application.Transpose(Target_Array)           End If     End With End Sub 


May God bless you, my great teacher, Yasser, and may God accept your fasting and resurrection and the good of your deeds

أثارت هذه المشاركة إعجاب: YasserKhalil،



look/images/icons/i1.gif نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق
  17-04-2021 09:56 مساءً   [6]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
استبدل الكود بهذا
CODE

Option Explicit

Sub without_zeros()
Dim Source_Array As Variant
Dim Target_Array()
Dim n%, i%
    With Sheets("ورقة1")
       Source_Array = .Range("K3").CurrentRegion
      .Range("D3").Resize(UBound(Source_Array), 2).Clear
       For i = 1 To UBound(Source_Array)
          If Source_Array(i, 1) <> 0 Then
             n = n + 1
             ReDim Preserve Target_Array(1 To 2, 1 To n)
             Target_Array(1, n) = Source_Array(i, 1)
             Target_Array(2, n) = Source_Array(i, 2)
           End If
        Next i
          
          If n Then
            .Range("D3").Resize(n, 2) = _
             Application.Transpose(Target_Array)
                 
           .Range("K3").CurrentRegion.Copy
           .Range("D3").Resize(n, 2).PasteSpecial 4
           Application.CutCopyMode = False
          .Range("D3").Select
       End If
    End With
End Sub


الملف مرفق
 
 
  test2.xlsm   تحميل xlsm مرات التحميل :(3)
الحجم :(25.78) KB


أثارت هذه المشاركة إعجاب: YasserKhalil، ali mohamed ali، Dreamier،



look/images/icons/i1.gif نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق
  17-04-2021 10:48 مساءً   [7]
معلومات الكاتب ▼
تاريخ الإنضمام : 23-01-2018
رقم العضوية : 3965
المشاركات : 45
الجنس :
تاريخ الميلاد : 25-10-1981
الدعوات : 1
قوة السمعة : 83
الاعجاب : 0
شكرا استاذ سليم علي اهتمامك وتعبك ولكن عند حذف بيانات من الجدول لا يتم نسخ التنسيق لنفس الترتيب الجدول blink
test2.xlsm


المشاركة الأصلية كتبت بواسطة: salim استبدل الكود بهذا
CODE
 Option Explicit Sub without_zeros() Dim Source_Array As Variant Dim Target_Array() Dim n%, i%     With Sheets("ورقة1")        Source_Array = .Range("K3").CurrentRegion       .Range("D3").Resize(UBound(Source_Array), 2).Clear        For i = 1 To UBound(Source_Array)           If Source_Array(i, 1) <> 0 Then              n = n + 1              ReDim Preserve Target_Array(1 To 2, 1 To n)              Target_Array(1, n) = Source_Array(i, 1)              Target_Array(2, n) = Source_Array(i, 2)            End If         Next i                      If n Then             .Range("D3").Resize(n, 2) = _              Application.Transpose(Target_Array)                              .Range("K3").CurrentRegion.Copy            .Range("D3").Resize(n, 2).PasteSpecial 4            Application.CutCopyMode = False           .Range("D3").Select        End If     End With End Sub 
الملف مرفق

 
 
  test2.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(19.04) KB





look/images/icons/i1.gif نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق
  18-04-2021 09:25 صباحاً   [8]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10522
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36735
الاعجاب : 177
أخي الكريم
وضعت لك كود في مشاركة سابقة. هل جربت الكود وأدى الغرض أم لا؟




look/images/icons/i1.gif نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق
  18-04-2021 02:38 مساءً   [9]
معلومات الكاتب ▼
تاريخ الإنضمام : 23-01-2018
رقم العضوية : 3965
المشاركات : 45
الجنس :
تاريخ الميلاد : 25-10-1981
الدعوات : 1
قوة السمعة : 83
الاعجاب : 0
فى حالة التعديل على الجدول تتكرر الصفوف
test4.xlsm


[quote = YasserKhalil] Dear brother
 
 
  test4.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(17.97) KB





look/images/icons/i1.gif نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق
  18-04-2021 04:56 مساءً   [10]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10522
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36735
الاعجاب : 177
هناك أمور بسيطة وبديهية يجب التفكير بها في الوصول للحل .. فالمنطقي أن تقوم بمسح النطاق الذي سيتم النسخ فيه طالما أن الكود سيتم تنفيذه بشكل متكرر وفي كل مرة عدد الصفوف مختلف .. لذا من الأفضل مسح النطاق بالكامل قبل بدء عملية النسخ
جرب التعديل التالي عله يحل الموضوع بشكل نهائي
CODE
Sub Test()
    With Sheets(1)
        .Range("D3").CurrentRegion.Clear
        With .Range("K3").CurrentRegion
            .AutoFilter 1, "<>0"
            .Copy .Parent.Range("D3")
            .AutoFilter
        End With
    End With
End Sub

أثارت هذه المشاركة إعجاب: Dreamier، ali mohamed ali، حسين مامون،





المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
دوره متكامله في الأكسس من خلال مشروع عملي شرح و تحليل قاعدة البيانات بكار للأبد
34 6474 alilo
طلب استخراج بيانات متخصصة لصفحة مستقلة اكسل وpdfمن جدول فعاليات بكار للأبد
1 37 بكار للأبد
طلب تعديل في ترحيل بيانات بشروط خاصة في الترحيل بكار للأبد
1 46 بكار للأبد
كود بحث مطاطي بأي جزء من البيانات علي بطيخ سالم
11 1909 star
طريقة استيراد بيانات من ملف اكسل عبدالرحمان بن حسين
1 111 عبدالرحمان بن حسين

الكلمات الدلالية
بيانات ، بدون ، السطور ، تحتوى ،









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

الساعة الآن 08:26 AM