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

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

محمد عبد الناصر
 مشاركة

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

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

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

قام بنشر
قام بنشر (معدل)

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

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

Book1.xlsx

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

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

قام بنشر
قام بنشر

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

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

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

 

  • Like 2
رابط هذا التعليق
شارك
محمد عبد الناصر

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

قام بنشر
  • الكاتب
قام بنشر
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

 

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
محمد عبد الناصر

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

قام بنشر
  • الكاتب
قام بنشر (معدل)


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

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

MD.xlsm

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

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

قام بنشر
  • الكاتب
قام بنشر

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

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

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

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

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

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

قام بنشر
قام بنشر

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

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

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

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

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

رابط هذا التعليق
شارك
محمد عبد الناصر

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

قام بنشر
  • الكاتب
قام بنشر (معدل)
40 minutes ago, ابراهيم الحداد said:

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

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

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

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

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

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

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

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

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

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



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept