اذهب الي المحتوي
أوفيسنا

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

قام بنشر

السلام عليكم

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

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

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

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

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

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

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

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

اليكم المرفق

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information