hani_2007 قام بنشر يونيو 12, 2011 مشاركة قام بنشر يونيو 12, 2011 السلام عليكم و رحمة الله و بركاته اخواني ارجوا منكم المساعدة في طلبي هذا وهو: المطلوب هو طريقة ادراج البيانات التي في كل خليه في ورقة2 على شكل افقي جنب بعض و عند الوصول الي كلمة end يذهب الى السطر التالي و ياخذ البيانات من السطر هذا و يكمل ادخلها افقي بجنب بعض حتى يصل الى كلمة end ثم يكرر هذا الاجراء حتى نهاية الورقه ليصبح الناتج مثل الذي في ورقة2 الانتقال الى خليه في حالة توفر شرط.rar رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر يونيو 12, 2011 مشاركة قام بنشر يونيو 12, 2011 السلام عليكم أخي العزيز تفضل المرفق ينقل كما تريد للورقة3 وهذا هو الكود يمكنك تعديلها إلي ورقة2 باستبدال كل Sheets(3) إلي Sheets(2) Sub copy_2_end() LstC = [IV1].End(xlToLeft).Column LstR = [A65530].End(xlUp).Row Range("A1", [A1].Offset(LstR - 1, LstC - 1)).Select i = 1: j = 1: f_end = 0 For Each ce In Selection If f_end = 1 Then GoTo 10 5 Sheets(3).Cells(i, j).Value = ce.Value j = j + 1 If ce.Value = "end" Then For x = j - 2 To 1 Step -1 If Sheets(3).Cells(i, x) <> "" Then Sheets(3).Cells(i, x + 1).Value = "end" Sheets(3).Cells(i, j - 1).ClearContents Exit For End If Next x i = i + 1 j = 1 f_end = 1 End If GoTo 20 10 If ce.Value <> "" Then f_end = 0: GoTo 5 20 Next ce [A1].select End Sub أنظر للورقة 3 قبل ضغط زر الكود تفضل المرفق الانتقال الى خليه في حالة توفر شرط.rar رابط هذا التعليق شارك More sharing options...
hani_2007 قام بنشر يونيو 12, 2011 الكاتب مشاركة قام بنشر يونيو 12, 2011 السلام عليكم أخي العزيز تفضل المرفق ينقل كما تريد للورقة3 وهذا هو الكود يمكنك تعديلها إلي ورقة2 باستبدال كل Sheets(3) إلي Sheets(2) Sub copy_2_end() LstC = [IV1].End(xlToLeft).Column LstR = [A65530].End(xlUp).Row Range("A1", [A1].Offset(LstR - 1, LstC - 1)).Select i = 1: j = 1: f_end = 0 For Each ce In Selection If f_end = 1 Then GoTo 10 5 Sheets(3).Cells(i, j).Value = ce.Value j = j + 1 If ce.Value = "end" Then For x = j - 2 To 1 Step -1 If Sheets(3).Cells(i, x) <> "" Then Sheets(3).Cells(i, x + 1).Value = "end" Sheets(3).Cells(i, j - 1).ClearContents Exit For End If Next x i = i + 1 j = 1 f_end = 1 End If GoTo 20 10 If ce.Value <> "" Then f_end = 0: GoTo 5 20 Next ce [A1].select End Sub أنظر للورقة 3 قبل ضغط زر الكود تفضل المرفق تسلم يمينك اخي طارق و الله تعجز الكلامات عن شكرك رابط هذا التعليق شارك More sharing options...
hani_2007 قام بنشر يونيو 12, 2011 الكاتب مشاركة قام بنشر يونيو 12, 2011 السلام عليكم أخي العزيز تفضل المرفق ينقل كما تريد للورقة3 وهذا هو الكود يمكنك تعديلها إلي ورقة2 باستبدال كل Sheets(3) إلي Sheets(2) Sub copy_2_end() LstC = [IV1].End(xlToLeft).Column LstR = [A65530].End(xlUp).Row Range("A1", [A1].Offset(LstR - 1, LstC - 1)).Select i = 1: j = 1: f_end = 0 For Each ce In Selection If f_end = 1 Then GoTo 10 5 Sheets(3).Cells(i, j).Value = ce.Value j = j + 1 If ce.Value = "end" Then For x = j - 2 To 1 Step -1 If Sheets(3).Cells(i, x) <> "" Then Sheets(3).Cells(i, x + 1).Value = "end" Sheets(3).Cells(i, j - 1).ClearContents Exit For End If Next x i = i + 1 j = 1 f_end = 1 End If GoTo 20 10 If ce.Value <> "" Then f_end = 0: GoTo 5 20 Next ce [A1].select End Sub أنظر للورقة 3 قبل ضغط زر الكود تفضل المرفق تسلم يمينك اخي طارق و الله تعجز الكلامات عن شكرك الاخ طارق بعد تطبيق المثال على الملف الدي اريده اعطاني هذا الخطا Sheets(3).Cells(i, j).Value = ce.Value ماهي المشكله الانتقال الى خليه في حالة توفر شرط1.rar رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر يونيو 12, 2011 مشاركة قام بنشر يونيو 12, 2011 (معدل) السلام عليكم بعد تطبيق المثال على الملف الدي اريده اعطاني هذا الخطا هذا لأنني لم أضع بالحسبان تلك العلامات الخاصة التي بالملف "علامات السالب" ------ ------ ---- -- وأيضا عدلت ترتيب السطرين التاليين واستبدلت كلمة "end" بكلمة " ## " Sheets(3).Cells(i, j - 1).ClearContents Sheets(3).Cells(i, x + 1).Value = " ## " الكود بعد التعديل أضفت خطوة لاستبدال أي علامة سالب بلاشيء Cells.Replace What:="-", Replacement:="" Sub copy_2_end() LstC = [IV1].End(xlToLeft).Column LstR = [A65530].End(xlUp).Row Range("A1", [A1].Offset(LstR - 1, LstC - 1)).Select i = 1: j = 1: f_end = 0 Cells.Replace What:="-", Replacement:="" For Each ce In Selection If f_end = 1 Then GoTo 10 5 Sheets(3).Cells(i, j).Value = ce.Value j = j + 1 If ce.Value = "end" Then For x = j - 2 To 1 Step -1 If Sheets(3).Cells(i, x) <> "" Or Left(Sheets(3).Cells(i, x), 1) <> "-" Then Sheets(3).Cells(i, j - 1).ClearContents Sheets(3).Cells(i, x + 1).Value = " ## " Exit For End If Next x i = i + 1 j = 1 f_end = 1 End If GoTo 20 10 If ce.Value <> "" Then f_end = 0: GoTo 5 20 Next ce [A1].Select End Sub تم تعديل يونيو 12, 2011 بواسطه TareQ M رابط هذا التعليق شارك More sharing options...
MAHMOUD ALI YOUSSEF قام بنشر يونيو 12, 2011 مشاركة قام بنشر يونيو 12, 2011 بارك الله في كل من ساهم في هذا المنتدي رابط هذا التعليق شارك More sharing options...
hani_2007 قام بنشر يونيو 12, 2011 الكاتب مشاركة قام بنشر يونيو 12, 2011 السلام عليكم بعد تطبيق المثال على الملف الدي اريده اعطاني هذا الخطا هذا لأنني لم أضع بالحسبان تلك العلامات الخاصة التي بالملف "علامات السالب" ------ ------ ---- -- وأيضا عدلت ترتيب السطرين التاليين واستبدلت كلمة "end" بكلمة " ## " Sheets(3).Cells(i, j - 1).ClearContents Sheets(3).Cells(i, x + 1).Value = " ## " الكود بعد التعديل أضفت خطوة لاستبدال أي علامة سالب بلاشيء Cells.Replace What:="-", Replacement:="" Sub copy_2_end() LstC = [IV1].End(xlToLeft).Column LstR = [A65530].End(xlUp).Row Range("A1", [A1].Offset(LstR - 1, LstC - 1)).Select i = 1: j = 1: f_end = 0 Cells.Replace What:="-", Replacement:="" For Each ce In Selection If f_end = 1 Then GoTo 10 5 Sheets(3).Cells(i, j).Value = ce.Value j = j + 1 If ce.Value = "end" Then For x = j - 2 To 1 Step -1 If Sheets(3).Cells(i, x) <> "" Or Left(Sheets(3).Cells(i, x), 1) <> "-" Then Sheets(3).Cells(i, j - 1).ClearContents Sheets(3).Cells(i, x + 1).Value = " ## " Exit For End If Next x i = i + 1 j = 1 f_end = 1 End If GoTo 20 10 If ce.Value <> "" Then f_end = 0: GoTo 5 20 Next ce [A1].Select End Sub بارك الله فيك و جعله في ميزان حسناتك و جزاك الله عنا كل خير رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.