جلب قيمة خلية من ملفات اكسل إذا تحقق شرط معين

[ابو تميم]

تحية طيبة

في المرفقات مجلد يحتوي على ملف اكسل اسمه main ومجلد اسمه DB والمجلد يحتوي على ملفات اكسل مرقمة تسلسليا

المطلوب

في ملفات الاكسل داخل المجلد DB إذا كانت قيمة الخلية D1 في الملف = 1 يتم جلب / نسخ قيمة الخلية C1 من هذا الملف وكتابتها في ملف الاكسل الذي اسمه main

بحيث يكون العمل في الملف main ضمن الجدول المحدد في الملف ويكون مداه العامود كاملا وبشرط أن تتم الكتابة بدون وجود فراغات في الجدول أي أني لا أريد أن أربط خلية معينة من الجدول بملف محدد وإنما تكون الكتابة في الجدول بشكل متسلسل وفي حال اختلاف الشرط في أحد الملفات يتم حذفه من الجدول في الملف main وهكذا

المهم أن يكون الجدول في الملف main لا يحتوي على فراغات ( خلايا فارغة ) ضمن العمود

علما أن النقل يكون أثناء وجود الملفين مفتوحين معا أي أن العمل على الملفين سيكون بنفس الوقت أي أنه لا يوجد ملف منهما مغلق

وأيضا العمل لا يقتصر على الملفات الخمسة في المجلد DB أي أنه يمكن أن تتكاثر هذه الملفات في المجلد وتتزايد يوميا

أرجو أن يكون السؤال واضح

جزاكم الله خيرا

mainbook.rar

تم تعديل ديسمبر 9, 2012 بواسطه ابو تميم

[الـعيدروس]

السلام عليكم

هذا الكود في حدث الورقة في كل الملفات التسلسليه

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, [D1]) Is Nothing Then

Dim Str_B As String

Dim T_A

Str_B = "main.xls"

If B_A(Str_B) Then

If Target.Value = 1 Then

Dim S As Worksheet

With Workbooks(Str_B)

T_A = Target.Offset(0, -1).Text

.Activate

Set S = .Sheets(1)

S.Cells(S.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row, 3) = T_A

End With

End If

Else

MsgBox Str_B & " الملف مغلق", vbOKOnly + vbExclamation

Exit Sub

End If

End If

End Sub

وهذا الكود في مودويل برضه في كل الملفات التسلسليه

Public Function B_A(Str_B As String) As Boolean

    Dim Work As Workbook

    On Error Resume Next

    Set Work = Workbooks(Str_B)

    On Error GoTo 0

    If Work Is Nothing Then

	    B_A = False

    Else

	    B_A = True

    End If

End Function

خلينا نشمي حبه حبه

اذا ملف main مغلق لاينفذ الكود

اذا خلية D1 = 1

ينسخ خلية C1 الى ملف main في العمود C بعد اخر خليه بها بيانات

* طيب متى ينفذ الشرط الاخر وهو حذف القيمة السابقة التي في ملف main

* هل هو بمجرد كتابة رقم غير 1 يروح يحذف القيمة السابقة من ملف main للملف الحالي فرضا هو 1 ?

* وهل مسموح التكرار قيمة من احد ملفات التسلسليه في ملف main ?

ارجو الرد

[ابو تميم]

جزاك الله خيرا أستاذ عباد

حتى الآن العمل ممتاز جدا وتم تنفيذ المطلوب الأول وهو نسخ قيمة الخلية C1 عند تحقق الشرط وهو وجود الرقم 1 في الخلية D1

أما الشرط الثاني وهو حذف القيمة السابقة للملف المحدد من الجدول في الملف main فهو يكون كما يلي

في الملفات التسلسلية تكون قيمة الخلية D1 إما 1 , 0 فإذا كانت 1 يتم تنفيذ الكود الاول وهو نسخ القيمة C1 إلى الجدول في main

أما إذا كانت قيمة الخلية D1 = 0 يتم حذف قيمة الخلية C1 الخاصة بالملف من الجدول ويتم سحب الجدول في main إلى الأعلى بحيث لا يبقى فراغات في الجدول

أما من ناحية التكرار فهو مستحيل لأن قيمة الملف إما أن تكون 1 , 0 وبهذا الحالة لا يمكن التكرار لأن وجود الملف نفسه في الجدول أكثر من مرة يعني إرسال نفس الملف إلى المصدر التالي بعدد مرات تكراره في الجدول

أرجو أن يكون الرد واضح

وجزاك الله كل الخير

تم تعديل ديسمبر 9, 2012 بواسطه ابو تميم

[الـعيدروس]

السلام عليكم

الاخ الحبيب ابو تميم

هذا نفس الكود السابق وعليه اضافات بسطيه

كود حدث الورقة في كل الملفات التسلسليه

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, [D1]) Is Nothing Then

Dim Str_B As String

Dim T_A

Str_B = "main.xls"

If B_A(Str_B) Then

If Target.Value = 1 Then

Dim s As Worksheet

With Workbooks(Str_B)

W_Name = ThisWorkbook.Name

T_A = Target.Offset(0, -1).Text

Set s = .Sheets(1)

L_A = s.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row

s.Cells(L_A, 3) = T_A

s.Cells(L_A, 2) = W_Name

End With

ElseIf Target.Value = 0 Then

Call Ali_D

End If

Else

MsgBox Str_B & " الملف مغلق", vbOKOnly + vbExclamation

Exit Sub

End If

End If

End Sub

وهذه الأكواد في مودويل انسخها لكل الملفات

Public Function B_A(Str_B As String) As Boolean

    Dim Work As Workbook

    On Error Resume Next

    Set Work = Workbooks(Str_B)

    On Error GoTo 0

    If Work Is Nothing Then

	    B_A = False

    Else

	    B_A = True

    End If

End Function

Public Sub Ali_D()

Dim Ar() As Variant

Dim Wo As Workbook, T_W As Workbook

Dim Sh As Worksheet

Dim Str_B As String

Dim R As Range

Dim i, ii, C, M_r, Rw

Str_B = "main.xls"

Set Wo = Workbooks(Str_B)

Set T_W = ThisWorkbook

Wo.Activate

Set Sh = Wo.Sheets(1)

Set R = Sh.Range("C2:C1000")

With R

For i = 1 To .Rows.Count

If Not .Cells(i, 1).Text = Empty And .Cells(i, 1).Text = T_W.Sheets(1).[C1] Then

ReDim Preserve Ar(0 To C)

Ar(C) = .Cells(i, 1).Address

C = C + 1

End If

Next

If Len(C) > 0 Then

For ii = LBound(Ar) To UBound(Ar)

Rw = Rw + 1

M_r = M_r & "," & Ar(ii)

Next

Wo.Sheets(1).Range(Mid(M_r, 2, Len(M_r))).EntireRow.Delete Shift:=xlUp

MsgBox "تم حذف القيمة المطابقة من ملف  : " & Wo.Name & " " & " عدد الصفوف التي تم حذفها :" & Rw, vbExclamation, "تنبية !!!"

Else

MsgBox "لاتوجد قيمة مماثله في : " & Wo.Name, vbExclamation, "تنبية !!!"

End If

End With

Erase Ar

T_W.Activate

End Sub

ارجو تجربة الأكواد

دمت في حفظ الله

[ابو تميم]

أستاذي ومعلمي العزيز ابو نصار

والله لقد أبهرتني بما قدمت وما كنت أتوقع خروج الملف بهذا الإبداع والإتقان

وإذا قلت لك بان هذا هو المطلوب من الملف فلن أكون صادقا معك لأن الإنجاز الذي وصلنا إليه في هذا الملف يفوق المطلوب بأضعاف مضاعفة

جزاك الله خيرا ورزقك زرقا حلالاً من حيث لا تحتسب

دمت في حفظ الله ورعايته

[منياوى]

جزاكم الله كل خير

[الـعيدروس]

الحمد الله الذي بنعمته تتم الصالحات

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

الاخ الفاضلjo11 اشكرك على مرورك الكريم

تقبلو تحياتي وشكري

[ابو تميم]

أستاذنا العزيز ابو نصار

بعد تجربتي للكود ومحاولة تحليل خفاياه لتطبيقه على ملف العمل عندي وجدت الملف يحتوي على أمور غامضة حاولت تعديل الكود وتغيير نطاق النسخ واسم الملف الذي يتم النسخ إليه ولكن واجهتني صعوبة في التطبيق

أرجو التكرم بتوضيح الأمور التي يجب علي تعديلها بحسب حاجة الملف عندي

والأمور التي أرغب بتوضيحهاهي ما يلي

==== في الملفات التسلسلية =======

1. أرغب بتغيير المكان الذي يتم فيه تحديد الرقم 1 لنسخ القيمة المطلوبة وهي هنا D1 .... أنا عدلتها في الملف ولكن للتاكد أرجو توضيحها على الكود

2. تعديل مكان الخلية التي يتم النسخ منها وهي هنا C1 أرغب بتغييرها إلى M1 مثلا أو غيرها بحسب مستجدات الملف

====== في الملف main ========

1. الورقة التي يتم النسخ إليها .... أنا حاولت في الملف ولكن لم أستطع تحديد الورقة التي يجب النسخ إليها ... وهل مسار الملف له علاقة ... وأيضا هل اسم المجلد DB له علاقة في الكود ؟؟؟؟

2. في الجدول إذا وضعنا في الملف التسلسلي رقم 1 في الخلية D1 اكثر من مرة يتم تكرار قيمة الخلية C1 في الجدول أكثر من مرة ... أرجو بعد إذنك تعديل الكود بحيث لا يسمح بتكرار نفس القيمة في الجدول وإشعار المستخدم بوجود الملف في الجدول فإذا رغب المستخدم بالتكرار يتم ذلك وإلا لا يتم تنفيذ الكود

================

أرجو أستاذنا ابو نصار التكرم بشرح بنود الكود داخل الكود نفيه لو تكرمت لأن الكود بالنسبة إلى شخص جديد في عالم الاكواد مثلي فهو صعب جدا ولا يمكنني تحليله بالطريقة التي تم تصميمه بها وهذا الكود لا يفهمه إلا شخص عملاق في هذا المجال مثلكم أستاذنا الكبير

أعلم أني أزعجتك بطلباتي فاعذرني جزاك الله خيرا

دمتم بالصحة والعافية

[ابو تميم]

الحمد لله رب العالمين

وأخيرا تمكنت من فهم الكود وتطبيقه وهو يعمل معي بشكل ممتاز

بقي لدينا مشكلة تكرار نفس اسم الملف في الجدول في الملف main

جزاكم الله خيرا

[ابو تميم]

أيضا استفسار آخر لو تكرمتم <<< مهم جدا >>>

هل يمكن ربط الكود الأول الذي موقعه حدث الورقة ويكون في موديول بدل من حدث الورقة ؟؟؟؟؟

جزاكم الله خيرا

[الـعيدروس]

السلام عليكم

جرب هكذا

موضح على الكود السطور الاختياريه

الكود في مودويل

Public Msg_a As String

Public Function B_A(Str_B As String) As Boolean

    Dim Work As Workbook

    On Error Resume Next

    Set Work = Workbooks(Str_B)

    On Error GoTo 0

    If Work Is Nothing Then

	    B_A = False

    Else

	    B_A = True

    End If

End Function

Public Sub Target_Ali()

With Application

   .EnableEvents = False

   .ScreenUpdating = False

   .DisplayAlerts = False

Dim خلية_الرقم As Range, خلية_المسار As Range

Set خلية_الرقم = Range("N1") ' هذا يعبر عن خلية إدخال الرقم غيرها الى اي خليه تريدها

Set خلية_المسار = Range("M1") ' هذا يعبر عن خلية مسار الملف غيرها الى اي خليه تريدها

If Not خلية_الرقم Is Nothing Then

Dim Str_B As String

Dim T_A, C, A

Str_B = "main.xls"

If B_A(Str_B) Then

If خلية_الرقم.Text = "" Then MsgBox " خلية الرقم فارغة  :" & خلية_الرقم.Address, vbExclamation, "تنبية !!!": Exit Sub

If خلية_الرقم.Value = 1 Then

'***************************

If Ali_TQrar(خلية_المسار) = True Then

'

A = GetSetting("Ali_A", "Ali_B", "Ali_C", (Msg_a))

'

MsgBox " هذه القيمة  :" & " " & خلية_المسار.Text & vbNewLine & vbCrLf & " موجوده في ملف  :" _

& Str_B & " " & vbNewLine & vbCrLf & " في الخلايا التالية :" & " " & A, vbInformation, "تنبية !!!"

'

DeleteSetting "Ali_A", "Ali_B"

'

Exit Sub

End If

'***************************

Dim s As Worksheet

With Workbooks(Str_B) ' هذا التعبير عن ملف Main

W_Name = ThisWorkbook.Name

T_A = خلية_المسار.Text

Set s = .Sheets(1) ' هنا رقم الورقة المراد لصق البيانات فيها في ملف Main

L_A = s.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Row ' هنا اخذ اخر صف به بيانات + صف من عمود C للصق القيم المنسوخه

s.Cells(L_A, "C") = T_A   ' تسجيل قيمة خلية المسار عمود C بإمكانك تغيره لأي عمود

s.Cells(L_A, "B") = W_Name ' تسجيل إسم ملف المنسوخ منه في عمود B

.Save

End With

ElseIf خلية_الرقم.Value = 0 Then

Call Ali_D

End If

Else

MsgBox Str_B & " الملف مغلق", vbOKOnly + vbExclamation

Exit Sub

End If

End If

  .DisplayAlerts = True

  .ScreenUpdating = True

  .EnableEvents = True

End With

End Sub

Private Sub Ali_D()

With Application

   .EnableEvents = False

   .ScreenUpdating = False

   .DisplayAlerts = False

Dim Ar() As Variant

Dim Wo As Workbook, T_W As Workbook

Dim Sh As Worksheet

Dim Str_B As String

Dim R As Range

Dim i, ii, C, M_r, Rw

Str_B = "main.xls"

Set Wo = Workbooks(Str_B)

Set T_W = ThisWorkbook

Wo.Activate

Set Sh = Wo.Sheets(1)

Set R = Sh.Range("C2:C1000")

With R

For i = 1 To .Rows.Count

If Not .Cells(i, 1).Text = Empty And .Cells(i, 1).Text = T_W.Sheets(1).[C1] Then

ReDim Preserve Ar(0 To C)

Ar(C) = .Cells(i, 1).Address

C = C + 1

End If

Next

If Len(C) > 0 Then

For ii = LBound(Ar) To UBound(Ar)

Rw = Rw + 1

M_r = M_r & "," & Ar(ii)

Next

Wo.Sheets(1).Range(Mid(M_r, 2, Len(M_r))).EntireRow.Delete Shift:=xlUp

MsgBox "تم حذف القيمة المطابقة من ملف  : " & Wo.Name & " " & " عدد الصفوف التي تم حذفها :" & Rw, vbExclamation, "تنبية !!!"

Else

MsgBox "لاتوجد قيمة مماثله في : " & Wo.Name, vbExclamation, "تنبية !!!"

End If

End With

Erase Ar

Wo.Save

T_W.Activate

  .DisplayAlerts = True

  .ScreenUpdating = True

  .EnableEvents = True

End With

End Sub

Public Function Ali_TQrar(خلية_المسار_A As Range) As Boolean

With Application

   .EnableEvents = False

   .ScreenUpdating = False

   .DisplayAlerts = False

Dim Max_r() As Variant

Dim Wo As Workbook, T_W As Workbook

Dim Sh As Worksheet

Dim Msar_B As String, Msg_a As String

Dim Va_Text As String

Dim R As Range, Rc As Range

Dim i, ii, Val_Ar, M_r, Rw

Msar_B = "main.xls"

Set Wo = Workbooks(Msar_B)

Set T_W = ThisWorkbook

Wo.Activate

Set Sh = Wo.Sheets(1) 'رقم الورقة في ملف Main

Set R = Sh.Range("C2:C1000") ' المدى المراد التحقق منه بياناته تحسبا للتكرار

Set Rc = خلية_المسار_A

Va_Text = Rc.Text ' خلية المسار في الملف التسلسلي

With R

For i = 1 To .Rows.Count

If Not .Cells(i, 1).Text = Empty And .Cells(i, 1).Text = Va_Text Then

ReDim Preserve Max_r(0 To Val_Ar)

Max_r(Val_Ar) = .Cells(i, 1).Address

Msg_a = Msg_a & vbCrLf & .Cells(i, 1).Address & vbCrLf

Debug.Print Msg_a

Val_Ar = Val_Ar + 1

End If

Next

'***********************************************

SaveSetting "Ali_A", "Ali_B", "Ali_C", (Msg_a)

'***********************************************

If Len(Val_Ar) > 0 Then Ali_TQrar = True

End With

Erase Max_r

T_W.Activate

  .DisplayAlerts = True

  .ScreenUpdating = True

  .EnableEvents = True

End With

End Function

[ابو تميم]

أستاذنا الكبير أبو نصار

جزاك الله خيرا تمت العملية بنجاح

الكود يعمل بشكل ممتاز جدا جدا ولا يوجد أية نواقص فقد جربت الكود في أكثر من حالة وهو يغطي أكثر من المطلوب بكثير

سلمت يداك وجزاك الله بكل حرف من هذا الكود العظيم آلاف الحسنات

دمت بصحة وعافية في حفظ الله تعالى

جزاكم الله خيرا وبارك فيكم

وأسأل الله تعالى أن ينعم عليك بفضله بأضعاف ما تتمناه وتتخيله

[الـعيدروس]

الحمد الله الذي بنعمة تتم الصالحات

اخي أبو تميم أشكرك جزيل الشكر على كلماتك المشجعه

ولك مثل دعائك أضعاف مضاعفه إن شاء الله

تقبل تحياتي وشكري