طلب تعديل على كود ترحيل بيانات

[wissamkh]

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

لدي هذا الكود لترحيل بيانات من خلية الى خلية اخرى

وأستعمله لعدة خلايا

أريد تعديل الكود أنه بحال كانت خلية من الخلايا المرحلة فارغة يتم تعبئتها تلقائيا بأي نص

حتى لا تتداخل بيانات الاسطر في الترحيل التالي.

يوجد ملف مرفق لشرح المقصود

وشكرا لكم 

 

Book1.xlsm

[ابراهيم الحداد]

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

استخدم هذا الكود بدلا من الكود المدرج بالملف

Sub settle2()
Dim LR As Long
LR = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
Range("K6:P6").Copy
Sheets("Sheet1").Range("C" & LR + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub

 

[سليم حاصبيا]

الكود طويل جداً و يحتوي على أكثر من مـرة SELECT & COPY & PASTE  هذا الاوامر ترهق الاكسل ولا لزوم لاستعمالها الا عند الضرورة

اليك هذا الكود البسبط

 

Option Explicit
Sub copy_data()
If ActiveSheet.Name <> "Sheet1" Then Exit Sub

 Dim R%, R1%
 R = Cells(Rows.Count, 3).End(3).Row + 1
 R1 = Range("K5", Range("K4").End(4)).Resize(, 6).Rows.Count
 
 Cells(R, 3).Resize(R1, 6).Value = _
 Range("K5", Range("K4").End(4)).Resize(, 6).Value
 Cells(R, 3).Resize(R1, 6).SpecialCells(4) = "EMPTY CELL"

End Sub

الملف مرفق

فقط اضغط الزر للتنفيذ

 

 

Samer Book.xlsm

[wissamkh]

شكرا لكم أخواني الاعزاء على المساعدة.

لاحظت في الملف المرفق أخي سليم أن الكود هو يبدأ من خلية و بعدها 6 خلايا متتالية.

أنا الملف الذي أعمل عليه، الخلاية المخصصة للترحيل ليست متتالية، يعني مثلا ممكن أن تكون الخلايا هكذا (c4,d12,e5,k16)

هل يمكن تحديد الشرط لكل خلية على حدة.

[wissamkh]

الملف الذي أعمل عليه شبيه بالملف المرفق

الخلاية ذات الحدود هي التي ترحل الى الجدول في الصفحة الثانية

bookk.xlsm

[سليم حاصبيا]

الملف الذي أرسلته معقد جداً

لذا قمت بوضع ملف جديد مشابه لما تريد

البيانات في الشيت 1 و النتيجة في الشيت2

الكود

Option Explicit

Sub eXtract_Data()
Dim s_rg As Range
Dim first$
Dim r%, c%, x
r = 1: c = 1
Sheets("Sheet2").Range("a1").CurrentRegion.ClearContents
Set s_rg = Sheets("Sheet1").Range("My_Rg").Find("*", _
after:=Sheets("Sheet1").Range("My_Rg").Cells(1, 1))
 If Not s_rg Is Nothing Then
  first = s_rg.Address
  
  Do
    Sheet2.Cells(r, c) = s_rg.Value
    c = c + 1
    If c = 9 Then
     r = r + 1: c = 1
     End If
     Set s_rg = Sheets("Sheet1").Range("My_Rg").FindNext(s_rg)
     If s_rg.Address = first Then Exit Do
   Loop

End If

End Sub

الملف مرفق

 

saerch_and_copy.xlsm

[wissamkh]

شكرا جزيلا لك أخ سليم