hani_2007 قام بنشر يونيو 12, 2011 قام بنشر يونيو 12, 2011 السلام عليكم و رحمة الله و بركاته اخواني ارجوا منكم المساعدة في طلبي هذا وهو: المطلوب هو طريقة ادراج البيانات التي في كل خليه في ورقة2 على شكل افقي جنب بعض و عند الوصول الي كلمة end يذهب الى السطر التالي و ياخذ البيانات من السطر هذا و يكمل ادخلها افقي بجنب بعض حتى يصل الى كلمة end ثم يكرر هذا الاجراء حتى نهاية الورقه ليصبح الناتج مثل الذي في ورقة2 الانتقال الى خليه في حالة توفر شرط.rar
طارق محمود قام بنشر يونيو 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
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 قبل ضغط زر الكود تفضل المرفق تسلم يمينك اخي طارق و الله تعجز الكلامات عن شكرك
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
طارق محمود قام بنشر يونيو 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
MAHMOUD ALI YOUSSEF قام بنشر يونيو 12, 2011 قام بنشر يونيو 12, 2011 بارك الله في كل من ساهم في هذا المنتدي
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 بارك الله فيك و جعله في ميزان حسناتك و جزاك الله عنا كل خير
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.