مساعده امر تجميع الوارد من كل الشيتات مساعده بالله عليكم متبهدل في الشغل

[محمد عبد الناصر]

الملف المرفق انا موضح مثال فيه 

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

Book1.xlsx

تم تعديل مارس 26, 2019 بواسطه محمد عبد الناصر

[محمد عبد الناصر]

up

[أحمد يوسف]

الأمر ليس بالسهل او الهين فهو صعب

[محمد عبد الناصر]

Just now, أحمد يوسف said:

الأمر ليس بالسهل او الهين فهو صعب

انا متمرمط في الشغل ومش عارف اعمل ايه ايدي وجعتني وعينيا من كتر الشغل ومش هخلص فشهر كمان 

[ابراهيم الحداد]

السلام عليكم ورحمة الله

الكود الاول للوارد :

Sub ImpData()
Dim ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Tmp As Variant
Dim LR As Long, i As Long, j As Long, p As Long, x As Integer
Set ws = Sheets("وارد")
For Each Sh In Sheets(Array("غيار رولة دهان كبيره ", "يد رولة دهان كبيره"))
Arr = Sh.Range("A10:Q100").Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 2) <> "" Then
p = p + 1
For j = 1 To 5
Tmp(p, j) = Arr(i, Choose(j, 2, 1, 17, 3, 13))
Next
End If
Next
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
If p > 0 Then ws.Range("A" & LR + 1).Resize(p, 5).Value = Tmp
p = 0
Next
End Sub

والكود الثانى للمنصرف :

Sub ExpData()
Range("A5:E1000").ClearContents
Dim ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Tmp As Variant
Dim LR As Long, i As Long, j As Long, p As Long, x As Integer
Set ws = Sheets("منصرف")
For Each Sh In Sheets(Array("غيار رولة دهان كبيره ", "يد رولة دهان كبيره"))

Arr = Sh.Range("A10:Q100").Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 6) <> "" Then
p = p + 1
For j = 1 To 5
Tmp(p, j) = Arr(i, Choose(j, 6, 5, 17, 9, 13))
Next
End If
Next
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
If p > 0 Then ws.Range("A" & LR + 1).Resize(p, 5).Value = Tmp
p = 0
Next

End Sub

 

[Ali Mohamed Ali]

بارك الله فيك استاذ ابراهيم عمل رائع وزادك الله من فضله

[محمد عبد الناصر]

10 hours ago, ابراهيم الحداد said:

السلام عليكم ورحمة الله

الكود الاول للوارد :

Sub ImpData()
Dim ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Tmp As Variant
Dim LR As Long, i As Long, j As Long, p As Long, x As Integer
Set ws = Sheets("وارد")
For Each Sh In Sheets(Array("غيار رولة دهان كبيره ", "يد رولة دهان كبيره"))
Arr = Sh.Range("A10:Q100").Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 2) <> "" Then
p = p + 1
For j = 1 To 5
Tmp(p, j) = Arr(i, Choose(j, 2, 1, 17, 3, 13))
Next
End If
Next
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
If p > 0 Then ws.Range("A" & LR + 1).Resize(p, 5).Value = Tmp
p = 0
Next
End Sub

والكود الثانى للمنصرف :

Sub ExpData()
Range("A5:E1000").ClearContents
Dim ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Tmp As Variant
Dim LR As Long, i As Long, j As Long, p As Long, x As Integer
Set ws = Sheets("منصرف")
For Each Sh In Sheets(Array("غيار رولة دهان كبيره ", "يد رولة دهان كبيره"))

Arr = Sh.Range("A10:Q100").Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 6) <> "" Then
p = p + 1
For j = 1 To 5
Tmp(p, j) = Arr(i, Choose(j, 6, 5, 17, 9, 13))
Next
End If
Next
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
If p > 0 Then ws.Range("A" & LR + 1).Resize(p, 5).Value = Tmp
p = 0
Next

End Sub

 

بااااااارك الله فيك  كود ممتاااز جدااااااااا ونفعني اوي 
بس في حاجه بسيطه انا اسف 
مش هعرف اضيف كل الشيتات في الكود انا عايز يجمع كل الوارد من غير ما اكتب اسم الشيت في الكود لان عندي اكتر من 500 ملف 

وفي حاجه تانيه لو دوست على الامر تاني بيكرر البيانات 
مش عايزه يكرر البيانات المكتوبه

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

[ابراهيم الحداد]

السلام عليكم ورحمة الله

استبدل الكودين السابقين بهذين الكودين و اخبرنى بالنتيجة

الكود الاول   :

Sub ImpData()
Dim ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Tmp As Variant
Dim LR As Long, i As Long, j As Long, p As Long, x As Integer
Set ws = Sheets("وارد")
For Each C In ws.Range("B5:B10000")
x = WorksheetFunction.CountIf(ws.Range("B5:B10000"), C.Value)
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name <> "وارد" Or Sh.Name <> "منصرف" Then
Arr = Sh.Range("A10:Q100").Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If x > 0 Then
MsgBox "عفوا  توجد بيانات قد تم ترحيلها من قبل سوف يتم الغاء العملية"
Exit Sub
Else
If Arr(i, 2) <> "" Then
p = p + 1
For j = 1 To 5
Tmp(p, j) = Arr(i, Choose(j, 2, 1, 17, 3, 13))
Next
End If
End If
Next
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
If p > 0 Then ws.Range("A" & LR + 1).Resize(p, 5).Value = Tmp
p = 0
End If
Next
Next
End Sub

الكود الثانى :

Sub ExpData()
Range("A5:E1000").ClearContents
Dim ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Tmp As Variant, x As Variant, C As Range
Dim LR As Long, i As Long, j As Long, p As Long
Set ws = Sheets("منصرف")
For Each C In ws.Range("B5:B10000")
x = WorksheetFunction.CountIf(ws.Range("B5:B10000"), C.Value)
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name <> "وارد" Or Sh.Name <> "منصرف" Then
Arr = Sh.Range("A10:Q100").Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If x > 0 Then
MsgBox "عفوا  توجد بيانات قد تم ترحيلها من قبل سوف يتم الغاء العملية"
Exit Sub
Else
If Arr(i, 6) <> "" Then
p = p + 1
For j = 1 To 5
Tmp(p, j) = Arr(i, Choose(j, 6, 5, 17, 9, 13))
Next
End If
End If
Next
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
If p > 0 Then ws.Range("A" & LR + 1).Resize(p, 5).Value = Tmp
p = 0
End If
Next
Next
End Sub

 

[محمد عبد الناصر]

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

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

MD.xlsm

تم تعديل مارس 27, 2019 بواسطه محمد عبد الناصر

[محمد عبد الناصر]

الف الف الف الف شكرررررر ليح استاااذ ابراهيم الحداد والله م عارف اقولك ايه 

الحمد لله عدلت على الملف وكله تمام عندي 

وبكره هخلص الشغل 

لولا فضلك وتكرمك بالمساعده كان زمان لسه قدامي شهريييين اف اف شكر 

[ابراهيم الحداد]

السلام عليكم ورحمة الله

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

و الله فى عون العبد مادام العبد فى عون اخيه

اذا حدث و اكتشفت اى عيوب فى الملف الرجاء فتح موضوع جديد

حتى لا يتوه الموضوع بين الموضوعات  بعد فترة من الزمن

[محمد عبد الناصر]

40 minutes ago, ابراهيم الحداد said:

السلام عليكم ورحمة الله

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

و الله فى عون العبد مادام العبد فى عون اخيه

اذا حدث و اكتشفت اى عيوب فى الملف الرجاء فتح موضوع جديد

حتى لا يتوه الموضوع بين الموضوعات  بعد فترة من الزمن

ماشاء الله عليك يارب يبارك فيك ويزيدك من علمه 

نفسي ابقى زيك ف الاكواد ازاي ابدء وحده وحده واتعلم حتى الاحتراف 

تم تعديل مارس 27, 2019 بواسطه محمد عبد الناصر