(تمت الاجابة) ترحيل بيانات من ملف الى ملف اخر بنفس الفولدر بشرط معين

[الـعيدروس]

السلام عليكم

الاساتذه الكرام

لي طلب مهم واتعشم فيكم الخير

لدي ملف يسجل فيه بيانات اريد ترحيل البيانات الى ملف اخر يعتبر

قاعدة بيانات والترحيل يكون بشرط كلمة (يعتمد) و (غير معتمد)

الصف الذي شرطه ( يعتمد) يرحل الى ملف الاكسل المسمى قاعدة البيانات

وغير معتمد لايرحل وهكذا

ملف ادخال البيانات المسمى (ترحيل)

ارجو ان يكون طلبي واضح

اليكم المرفق

fold.rar

[طارق محمود]

السلام عليكم

تفضل اخي المرفق

بشرط ان يكون الملفين في نفس المجلد

وهذا هو الكود بالتفصيل

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

[الشهابي]

كود رائع أخينا طارق جزاك الله خير

[الـعيدروس]

السلام عليكم

الاستاذ القدير طارق محمود كود ولااروع جعله الله في ميزان حسناتك

اتعشم بإضافة بسيطة

وهو حذف الصفوف المرحلة من ملف ترحيل

واما قاعدة البيانات بعد ترحيل البيانات اليها يغلق الملف

وارجو الا اكون اثقلت عليك بطلباتي

[الـعيدروس]

السلام عليكم

استاذنا القدير حاولت اضيف على كودك طلبي الاخير وزبط معي الحمد لله

هذا الكود بعد الاضافة للفائده العامة

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

[الشهابي]

الأخ العيدروس ماشاء الله أستاذ يتلقى من أستاذ

تم تعديل نوفمبر 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

جزاك الله خير ونور دروبك كما تنورنا بالعلم

[طارق محمود]

تمام

الحمد لله