اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


الردود الموصى بها

السلام عليكم

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

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

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

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

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

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

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

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

اليكم المرفق

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

  • Like 1
رابط هذا التعليق
شارك

السلام عليكم

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

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

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

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

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

رابط هذا التعليق
شارك

السلام عليكم

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

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


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

  • Like 1
رابط هذا التعليق
شارك

السلام عليكم

أخي الحبيب / العيدروس

ماشاء الله ، إضافة جميلة

طلبك الأخر أيضا إن شاء بسيط

سأترك لك المجال لييظبط معك بإذن الله

...<<<< مساعدة بسيطة >>>>...

ممكن تستخدم خاصية الفلتر (التصفية)

بتصفية البيانات التي = يعتمد فقط ثم إزالة الأسطر بالكامل ثم إلغاء مود الفلتر

رابط هذا التعليق
شارك

وعليكم السلام

الاستاذ الحبيب والخلوق جدا طارق محمود

جزئية حذف سطور (يعتمد) تم معي بهذا الجزء

لم استخدم الفلترة


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

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

  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information