أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
هانى على ali mohamed ali-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة منع ادخال البيانات بعدة شروط اكسيل اسئله واجابات


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





نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق

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


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


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

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

طلب كود بسيط لنسخ البيانات من عمودين لعمودين بدون السطور التى تحتوى على صفر الموضوع مدموج من مواضيع متعدّدة
 
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



أفضل إجابة مقدمة من YasserKhalil وهي:
هناك أمور بسيطة وبديهية يجب التفكير بها في الوصول للحل .. فالمنطقي أن تقوم بمسح النطاق الذي سيتم النسخ فيه طالما أن الكود سيتم تنفيذه بشكل متكرر وفي كل مرة عدد الصفوف مختلف .. لذا من الأفضل مسح النطاق بالكامل قبل بدء عملية النسخ
جرب التعديل التالي عله يحل الموضوع بشكل نهائي
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
عرض الإجابة




06-11-2020 06:11 مساء
مشاهدة مشاركة منفردة [1]
حسين مامون
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 23-08-2017
رقم العضوية : 69
المشاركات : 172
الجنس : ذكر
الدعوات : 1
يتابعهم : 5
يتابعونه : 11
قوة السمعة : 957
عدد الإجابات: 22
 offline 
look/images/icons/i1.gif نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق
جرب الكود
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

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

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب

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

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

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

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

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

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



الصفحة 1 من 2 < 1 2 > الأخيرة »


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


 










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

الساعة الآن 06:36 صباحا