أبوعبدالرحمن- قام بنشر يناير 7, 2012 قام بنشر يناير 7, 2012 السلام عليكم ورحمة الله وبركاته الاخوة الأفاضل بارك الله فيكم جميعا على هذا الصرح العملاق الذي يعتبر والله موسوعة شاملة وكاملة لمن أراد السؤال او التعلم فجزا الله القائمين من ( إدارة وخبراء ومختصين واعضاء ) على هذا العلم الذي نثروه بين أيدينا وان لا يحرمهم الله أجر ماقدموا وجزاهم الله كل خير اخواني الأفاضل لدي ملف رئيسي ييقوم بإستيراد البيانات من ملفات أخرى داخل مجلد والحقيقة أن الاخ أبو نصار ( Alidoors ) مأجورا مشكورا قد اجاب على تساؤلي حول استيراد البيانات من الملفات الأخرى إلى الملف الرئيسي ولكن واجهتني مشكلة وهي أن استيراد البيانات تتم لكامل الصفوف حتى تلك الصفوف التي تحتوي قيمه خلاياها على صفر وما اريه هو استيراد البيانات بشرط ان تكون قيم الصفوف لا تحتوي على صفر فإن كان الصف كاملا يحتوي على صفر فلا يتم استيراده ارجوا من الله ثم منكم العن في هذا الأمر ولكم مني كل الشكر والتقدير Mine.rar
أبوعبدالرحمن- قام بنشر يناير 7, 2012 الكاتب قام بنشر يناير 7, 2012 ارجوا من الاخوة العباقرة أن يبدو رأيهم في هذا الأمر
الـعيدروس قام بنشر يناير 8, 2012 قام بنشر يناير 8, 2012 السلام عليكم تحايلنا بحذف الصفوف ذات القيمة صفر Sub COPY_ALIDROOS() On Error Resume Next Dim W_ALI As Workbook, WB_ALI As Workbook, N_ALI$, CH_ALI$, SH_ALI As Worksheet Dim T%, R% Dim X As Range ' Dim S_A ' S_A = Union(SH_ALI.Range("A3:A" & R), SH_ALI.Range("E3:E" & R), SH_ALI.Range("F3:F" & R)) Application.ScreenUpdating = 0 '============================================ ' هنا تحط مسار مجلد الملفات التي تريد جلب بياناتها CH_ALI = "C:\Mine\" '============================================ N_ALI = Dir(CH_ALI & "\*.xlsx") Set W_ALI = ThisWorkbook Do While N_ALI <> "" Set WB_ALI = Workbooks.Open(CH_ALI & "\" & N_ALI) For Each SH_ALI In WB_ALI.Worksheets R = SH_ALI.Cells(Rows.Count, 1).End(xlUp).Row W_ALI.Activate '============================================ '(A-E-F)هنا الاعمدة المراد جلب بياناتها هيا حسب طلبك هيا ' إبتداء من السطر الثالث If SH_ALI.Range("C3:C" & R).Value <> 0 Then Union(SH_ALI.Range("A3:A" & R), SH_ALI.Range("E3:E" & R), SH_ALI.Range("F3:F" & R)).Copy '============================================ T = Cells(Rows.Count, 1).End(xlUp).Row + 1 ThisWorkbook.Worksheets(1).Range("A" & T).PasteSpecial xlPasteValues End If Next SH_ALI N_ALI = Dir WB_ALI.Close 0 Loop With ورقة1 For Each X In .Range("C3:C5000") If X.Value = 0 Then X.EntireRow.Delete End If Next X End With Application.ScreenUpdating = 1 End Sub 1
عبدالله باقشير قام بنشر يناير 8, 2012 قام بنشر يناير 8, 2012 السلام عليكم تم التعديل على كود ابو انصار حفظه الله Sub COPY_ALIDROOS() Dim W_ALI As Workbook, WB_ALI As Workbook Dim N_ALI$, CH_ALI$ Dim SH_ALI As Worksheet Dim T%, R%, co% Application.ScreenUpdating = False '============================================ ' هنا تحط مسار مجلد الملفات التي تريد جلب بياناتها CH_ALI = "C:\Mine\" 'CH_ALI = ThisWorkbook.Path & "\Mine\" '============================================ N_ALI = Dir(CH_ALI & "\*.xlsx") Set W_ALI = ThisWorkbook Do While N_ALI <> "" Set WB_ALI = Workbooks.Open(CH_ALI & "\" & N_ALI) Set SH_ALI = WB_ALI.Worksheets(1) R = SH_ALI.Cells(Rows.Count, 1).End(xlUp).Row If R = 2 Then GoTo 1 '============================================ '(A-E-F)هنا الاعمدة المراد جلب بياناتها هيا حسب طلبك هيا ' إبتداء من السطر الثالث Union(SH_ALI.Range("A3:A" & R), SH_ALI.Range("E3:E" & R), SH_ALI.Range("F3:F" & R)).Copy '============================================ W_ALI.Activate With W_ALI.Worksheets(1) T = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 .Range("A" & T).PasteSpecial xlPasteValues kh_Delete Selection End With 1: WB_ALI.Close 0 N_ALI = Dir Loop Application.ScreenUpdating = True Set W_ALI = Nothing: Set WB_ALI = Nothing: Set SH_ALI = Nothing End Sub Sub kh_Delete(Rng As Range) Dim Col As Range, Rw% With Rng For Rw = 1 To .Rows.Count If Val(.Cells(Rw, 2)) + Val(.Cells(Rw, 3)) = 0 Then If Col Is Nothing Then Set Col = .Rows(Rw) Else _ Set Col = Union(Col, .Rows(Rw)) End If Next End With If Not Col Is Nothing Then Col.Delete Shift:=xlUp End If End Sub شاهد المرفق2007 MAIN.rar 1
الـعيدروس قام بنشر يناير 8, 2012 قام بنشر يناير 8, 2012 جزا الله كل خير استاذ عبدالله فعلا انت صائغ اكواد بمعنى الكلمة
أبوعبدالرحمن- قام بنشر يناير 8, 2012 الكاتب قام بنشر يناير 8, 2012 جزاكم الله خيرا اخواني الأفاضل الحقيقة هي أنكم مبدعون ولا نقف مع هذا الإبداع إلا بدعوة بظهر الغيب على ما تقدمونه جزاكم الله كل خير ملاحظة بسيطة ... عند التعديل على اسماء الملفات تظهر رسالة خطأ ... ( لو تم تعديل اسماء ملفات البيانات A B C D E إلى اسماء اخرى تظهر رسالة الخطأ ..فهل من حل ..
أبوعبدالرحمن- قام بنشر يناير 8, 2012 الكاتب قام بنشر يناير 8, 2012 السلام عليكم ورحمة الله وبركاته أخي الفاضل ابو نصار الحقيقة أنه لا يوجد خطأ بل كان خطأي أنا والكود يعمل بكل جودة وكفاءة سؤال بسيط اخي الفاضل في الكود السابق تم تحديد جلب البيانات لبعض الأعمدة (A - E - F ) فإذا كان المطلوب جلب البيانات لعدد أكثر من الأعمدة مثلاً ( من العمود A وحتى العمود AM ) فكيف سيتم ذلك لك شكري وتقديري
الـعيدروس قام بنشر يناير 8, 2012 قام بنشر يناير 8, 2012 استبدل هذا السطر Union(SH_ALI.Range("A3:A" & R), SH_ALI.Range("E3:E" & R), SH_ALI.Range("F3:F" & R)).Copy بهذا SH_ALI.Range(Cells(R, 1), Cells(R, 39)).Copy
أبوعبدالرحمن- قام بنشر يناير 8, 2012 الكاتب قام بنشر يناير 8, 2012 لله درك على سرعة تجاوبك اسأل الله ان يبارك لك في علمك تبارك الله ما شاءالله جزاك الله خير اخي العزيز
أبوعبدالرحمن- قام بنشر يناير 10, 2012 الكاتب قام بنشر يناير 10, 2012 السلام عليكم ورحمة الله وبركاتهه اخوتي الأفاضل بعد استبدال الكود ... بالكود الجديد ظهر الخطأ التالي :
عبدالله باقشير قام بنشر يناير 10, 2012 قام بنشر يناير 10, 2012 السلام عليكم هذا السطر SH_ALI.Range(Cells(R, 1), Cells(R, 39)).Cop SH_ALI.Range(Cells(3, 1), Cells(R, 39)).Copy جرب لنسخ السطر الاخير استبدل بهذا
الـعيدروس قام بنشر يناير 10, 2012 قام بنشر يناير 10, 2012 السلام عليكم اعتذر على هذا الخطاء فعلا كما اشار استاذنا الحبيب خبور جزاك الله خير استاذ عبدالله
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.