الـعيدروس قام بنشر نوفمبر 20, 2011 قام بنشر نوفمبر 20, 2011 السلام عليكم الاساتذه الكرام لي طلب مهم واتعشم فيكم الخير لدي ملف يسجل فيه بيانات اريد ترحيل البيانات الى ملف اخر يعتبر قاعدة بيانات والترحيل يكون بشرط كلمة (يعتمد) و (غير معتمد) الصف الذي شرطه ( يعتمد) يرحل الى ملف الاكسل المسمى قاعدة البيانات وغير معتمد لايرحل وهكذا ملف ادخال البيانات المسمى (ترحيل) ارجو ان يكون طلبي واضح اليكم المرفق fold.rar
طارق محمود قام بنشر نوفمبر 21, 2011 قام بنشر نوفمبر 21, 2011 السلام عليكم تفضل اخي المرفق بشرط ان يكون الملفين في نفس المجلد وهذا هو الكود بالتفصيل Sub T_shift() file1 = ActiveWorkbook.Name pth = ActiveWorkbook.Path f2Name = "قاعدة بيانات.xls" file2 = pth & "\" & f2Name On Error Resume Next 'إحتياطي لإحتمال ان يكون ملف قاعدة بيانات مفتوح بالفعل Set F_check = Excel.Workbooks(f2Name) If Err = 0 Then GoTo 10 Workbooks.Open Filename:=file2 10 'وضع خط أسفل آخر قيم في ملف قاعدة بيانات rr = Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Row Workbooks(f2Name).Sheets(1).Range("A" & rr & ":G" & rr).Borders(xlEdgeBottom).LineStyle = xlContinuous Workbooks(f2Name).Sheets(1).[a1].Select Workbooks(file1).Activate ' نسخ قيم فقط للبيانات التي توافق الشرط For a = 2 To [G1000].End(xlUp).Row If Cells(a, 7) = "يعتمد" Then Range(Cells(a, 1), Cells(a, 7)).Copy Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues ic = ic + 1 End If Next a Application.CutCopyMode = False 'وضع خط مرة أخري أسفل آخر قيم في ملف قاعدة بيانات rr = Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Row Workbooks(f2Name).Sheets(1).Range("A" & rr & ":G" & rr).Borders(xlEdgeBottom).LineStyle = xlContinuous 'رسالة بالبيانات المرحلة MsgBox (" تم ترحيل عدد" & ic & " بيان معتمد بنجاح") [a1].Select Workbooks(f2Name).Activate Range("A" & rr + 1).Select 'رسالة أخري من ملف قاعدة بيانات للتأكيد MsgBox "!تمام", vbInformation + vbMsgBoxRight, "تم الترحيل" Workbooks(file1).Activate End Sub ترحيل_TAREQ.rar 1
الـعيدروس قام بنشر نوفمبر 21, 2011 الكاتب قام بنشر نوفمبر 21, 2011 السلام عليكم الاستاذ القدير طارق محمود كود ولااروع جعله الله في ميزان حسناتك اتعشم بإضافة بسيطة وهو حذف الصفوف المرحلة من ملف ترحيل واما قاعدة البيانات بعد ترحيل البيانات اليها يغلق الملف وارجو الا اكون اثقلت عليك بطلباتي
الـعيدروس قام بنشر نوفمبر 21, 2011 الكاتب قام بنشر نوفمبر 21, 2011 السلام عليكم استاذنا القدير حاولت اضيف على كودك طلبي الاخير وزبط معي الحمد لله هذا الكود بعد الاضافة للفائده العامة Sub T_shift() file1 = ActiveWorkbook.Name pth = ActiveWorkbook.Path f2Name = "قاعدة بيانات.xls" file2 = pth & "\" & f2Name On Error Resume Next 'إحتياطي لإحتمال ان يكون ملف قاعدة بيانات مفتوح بالفعل Set F_check = Excel.Workbooks(f2Name) If Err = 0 Then GoTo 10 Workbooks.Open Filename:=file2 10 'وضع خط أسفل آخر قيم في ملف قاعدة بيانات rr = Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Row Workbooks(f2Name).Sheets(1).Range("A" & rr & ":G" & rr).Borders(xlEdgeBottom).LineStyle = xlContinuous Workbooks(f2Name).Sheets(1).[a1].Select Workbooks(file1).Activate ' نسخ قيم فقط للبيانات التي توافق الشرط For a = 2 To [G1000].End(xlUp).Row If Cells(a, 7) = "يعتمد" Then Range(Cells(a, 1), Cells(a, 7)).Copy Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues ic = ic + 1 End If Next a Application.CutCopyMode = False Application.ScreenUpdating = False Sheets("ورقة1").Select LastRow = Cells(Rows.Count, 1).End(xlUp).Row For y = LastRow To 2 Step -1 If Cells(y, "g").Value = "يعتمد" Then Rows(y).EntireRow.Delete Next y Application.ScreenUpdating = True 'وضع خط مرة أخري أسفل آخر قيم في ملف قاعدة بيانات rr = Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Row Workbooks(f2Name).Sheets(1).Range("A" & rr & ":G" & rr).Borders(xlEdgeBottom).LineStyle = xlContinuous 'رسالة بالبيانات المرحلة MsgBox (" تم ترحيل عدد" & ic & " بيان معتمد بنجاح") [a1].Select Workbooks(f2Name).Activate Range("A" & rr + 1).Select 'رسالة أخري من ملف قاعدة بيانات للتأكيد MsgBox "!تمام", vbInformation + vbMsgBoxRight, "تم الترحيل" Workbooks(file1).Activate With Workbooks(f2Name) .Save .Close End With End Sub 1
الشهابي قام بنشر نوفمبر 21, 2011 قام بنشر نوفمبر 21, 2011 (معدل) الأخ العيدروس ماشاء الله أستاذ يتلقى من أستاذ تم تعديل نوفمبر 21, 2011 بواسطه الشهابي
طارق محمود قام بنشر نوفمبر 21, 2011 قام بنشر نوفمبر 21, 2011 السلام عليكم أخي الحبيب / العيدروس ماشاء الله ، إضافة جميلة طلبك الأخر أيضا إن شاء بسيط سأترك لك المجال لييظبط معك بإذن الله ...<<<< مساعدة بسيطة >>>>... ممكن تستخدم خاصية الفلتر (التصفية) بتصفية البيانات التي = يعتمد فقط ثم إزالة الأسطر بالكامل ثم إلغاء مود الفلتر
طارق محمود قام بنشر نوفمبر 21, 2011 قام بنشر نوفمبر 21, 2011 السلام عليكم أخي الكريم / الشهابي أشكرك كثيرا لمروك الطيب وكلماتك العطرة تقبل ودي
الـعيدروس قام بنشر نوفمبر 21, 2011 الكاتب قام بنشر نوفمبر 21, 2011 وعليكم السلام الاستاذ الحبيب والخلوق جدا طارق محمود جزئية حذف سطور (يعتمد) تم معي بهذا الجزء لم استخدم الفلترة Application.ScreenUpdating = False Sheets("ورقة1").Select LastRow = Cells(Rows.Count, 1).End(xlUp).Row For y = LastRow To 2 Step -1 If Cells(y, "g").Value = "يعتمد" Then Rows(y).EntireRow.Delete Next y Application.ScreenUpdating = True جزاك الله خير ونور دروبك كما تنورنا بالعلم 1
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.