مختار حسين محمود

أستاذ ى و أخى ياسر وأنا أيضاُ توصلت للحل أحب أن أشاركم به ضع الكود التالى فى ملف Option Explicit Sub export_data() 'تعريف المتغير من النوع نصي Dim Path As String 'تعريف المتغير من النوع نصي Dim Filename As String Dim Amro As Workbook Set Amro = ThisWorkbook 'تعيين المتغير ليساوي مسار المجلد الذي يحوي المصنفات المراد دمج أوراق العمل منها Path = ThisWorkbook.Path & "\OUTPUT\" 'تعيين المتغير ليساوي اسم كل مصنف من المصنفات التي سيتم التعامل معها Filename = Dir(Path & "*.xls") 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'إلغاء خاصية التنبيه بالرسائل Application.DisplayAlerts = False 'حلقة تكرارية للمصنفات الموجودة في المسار المحدد إلى أن لا يجد أي مصنف بالمسار Do While Filename <> "" 'فتح المصنف Workbooks.Open Filename:=Path & Filename 'نسخ ولصق البيانات Amro.Sheets(1).Range("A1:a2").Copy ActiveWorkbook.Sheets.Select Range("A1").Activate ActiveSheet.Paste Application.CutCopyMode = False 'حفظ وغلق الملفات Workbooks(Filename).Save Workbooks(Filename).Close 'إعادة ضبط المتغير Filename = Dir() Loop 'تفعيل خاصية التنبيه بالرسائل Application.DisplayAlerts = True 'تفعيل خاصية اهتزاز الشاشة 'Application.ScreenUpdating = True End Sub ياعمرو ضع الــــ 1500 ملف فى مجلد باسم OUTPUT جنب ملف شغل الكود ستجد البيانات فى كل ورقه من أو أى ملف من الملفات مها كان عدد الأوراق والملفات تحياتى

خلى بالك يا بو سليمان لما نريد نقل بضاعة من مكان الى مكان يلزمنا عربية نقل وسواق شاطر عربية النقل هى الدوال دى نسيبها زى ما هيه فى الملف الرئيسى Public Sub GetData(SourceFile As Variant, SourceSheet As String, _ SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean) Dim rsCon As Object Dim rsData As Object Dim szConnect As String Dim szSQL As String Dim lCount As Long ' Create the connection string. If Header = False Then If Val(Application.Version) < 12 Then szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 8.0;HDR=No"";" Else szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 12.0;HDR=No"";" End If Else If Val(Application.Version) < 12 Then szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 8.0;HDR=Yes"";" Else szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 12.0;HDR=Yes"";" End If End If If SourceSheet = "" Then ' workbook level name szSQL = "SELECT * FROM " & SourceRange$ & ";" Else ' worksheet level name or range szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];" End If On Error GoTo SomethingWrong Set rsCon = CreateObject("ADODB.Connection") Set rsData = CreateObject("ADODB.Recordset") rsCon.Open szConnect rsData.Open szSQL, rsCon, 0, 1, 1 ' Check to make sure we received data and copy the data If Not rsData.EOF Then If Header = False Then TargetRange.Cells(1, 1).CopyFromRecordset rsData Else 'Add the header cell in each column if the last argument is True If UseHeaderRow Then For lCount = 0 To rsData.Fields.Count - 1 TargetRange.Cells(1, 1 + lCount).Value = _ rsData.Fields(lCount).Name Next lCount TargetRange.Cells(2, 1).CopyFromRecordset rsData Else TargetRange.Cells(1, 1).CopyFromRecordset rsData End If End If Else MsgBox "No records returned from : " & SourceFile, vbCritical End If ' Clean up our Recordset object. rsData.Close Set rsData = Nothing rsCon.Close Set rsCon = Nothing Exit Sub SomethingWrong: MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _ vbExclamation, "Error" On Error GoTo 0 End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function Array_Sort(ArrayList As Variant) As Variant Dim aCnt As Integer, bCnt As Integer Dim tempStr As String For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1 For bCnt = aCnt + 1 To UBound(ArrayList) If ArrayList(aCnt) > ArrayList(bCnt) Then tempStr = ArrayList(bCnt) ArrayList(bCnt) = ArrayList(aCnt) ArrayList(aCnt) = tempStr End If Next bCnt Next aCnt Array_Sort = ArrayList End Function السواق ( لازم يكون شاطر ولو خايب نغيره ) احنا بقى السواق بتاعنا هو الكود ده Sub GetData_bymokhtar() GetData ThisWorkbook.Path & "\bosoliman1.xls", "_4300", "A1:a", Sheets("الرئسية").Range("A2"), True, True GetData ThisWorkbook.Path & "\bosoliman2.xls", "_6050", "A1:a", Sheets("الرئسية").Range("i2"), True, True GetData ThisWorkbook.Path & "\bosoliman3.xls", "_8011", "A1:a", Sheets("الرئسية").Range("q2"), True, True GetData ThisWorkbook.Path & "\bosoliman4.xls", "_TASI", "A1:a", Sheets("الرئسية").Range("y2"), True, True GetData ThisWorkbook.Path & "\bosoliman5.xls", "81401", "A1:a", Sheets("الرئسية").Range("ag2"), True, True End Sub لاحظ أن السواق يجب أن يكون عارف هو بيحمل ايه وعدده كام عشان ده بيفرق فى الأجره بص فى الكود كده هتلاقى خمس سطور بعدد الملفات اللى هنحمل منها بضاعة كل سطر خاص بملف فى أى سطر من الخمسة بنقول للسواق : من الملف الذى اسمه كذا اللى فى مسارك حمّل المدى الفلانى ( من الخلية .... الى الخلية ....) من الشيت اللى اسمه .......وتعالى حطه فى ملف الرئيسية اعتبارا من الخلية ...... بس كدا خلاص البضاعة وصلت ==== قسمنا البيان ده 12/30/2007,38.70,39.00,36.70,38.30,86849042,38.30 بدالة StrSplit دى Function StrSplit(InString, Pos, Delim) StrArray = Split(InString, Delim) StrSplit = StrArray(Pos - 1) End Function نستعملها ازاى : قف خلية اضغط fx عند شريط المعادلات هتلاقى الاكسل بيقولك أدرج داله اختر من القائمة المنسدلة user defined مثال =IF(A2="";"";StrSplit(A2;1;",")) دى تعطيك الجزء الأول من الرقم =IF(A2="";"";StrSplit(A2;2;",")) دى تعطيك الجزء الثانى من الرقم =IF(A3="";"";StrSplit(A3;3;",")) دى تعطيك الجزء الثالث من الرقم وهكذا بعد ما تخلص من المعادلة شدها لتحت وتوتة توتة فرغت الحدوتة حلوة ولا ملتوتة

جازَى: ( فعل ) جزى ( فعل ) وهما متشابهان جَازَاهُ عن أعماله أثابه على حسن تصرفه أو عاقبه على سوء تصرفه ( حسب السياق ) جزاه على عمله أثابه على حسن تصرفه أو عاقبه على سوء تصرفه ( حسب السياق ) جزاك الله خيرًا من الفعل جزى صح وهى من الصيغ المتداولة للتعبير عن الاحترام والتقدير والمحبة والدعاء بالخير للمخاطب جازاك الله خيرًا من الفعل جازى صح أيضا وهى من الصيغ المتداولة للتعبير عن التقدير والمحبة والدعاء بالخير للمخاطب جازاكم الله خيرًا من الفعل جازى الميم لتعظيم المخاطب أو إعلاء قدره اللى هو حضرتك تحياتى

بارك الله فيك أخى وأستاذى ياسر وهذا كود أخر لحفظ مدى محدد بصيغة PDF Sub Save_Range_As_PDF() ActiveSheet.Range("A1:h53").ExportAsFixedFormat Type:=xlTypePDF, _ Filename:="H:\Test pdf File.pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True End Sub غير الاسم والمسار الى ما تحب طبقت الكود على المرفق مثال بس غيرت اسم الملف فقط حفظ مدى محدد بصيغة PDF.rar

وأنا أحب اللى ما بيفوتش لأنه يذكرنى بخطئى ومن ذكرنى بخطئى دفعنى الى الصواب جازاكم الله خيرا

أخى وحبيبى فى الله ياسر بارك الله فيك وأشكرك على الملاحظة هذا بسبب السرعة فى العمل عند تعديل المتغيرات فى الأكواد الأصلية ولما وجدت أن الكود اشتغل لم أراجع متعيراته معك كل الحق والهدية مقبوله النبى ( ص ) قبل الهدية صليت على النبى ولا لسه !!!!

عفوا يا عمرو ماكنتش واخد بالى من الـــ 1500 ملف دى كنت فاكر أنهم 3 عشان كده عملت الكود بالشكل ده وربطت الشيتات ببعض على العموم تحياتى وان شاء الله تجد الحل

لا أخى سليمان

أولا أهلا وسهلا بك حليموووووووووووو ثانيا راجع توجيهات الأستاذ ياسر صفحة 1 فى المنتدى ثالثا تفضل الملف الحفظ كالتالى اتوماتيكى كل دقيقة يمكنك تغييره بسهولة الى 4 ساعات كما تريد الحفظ يكون الى بارتش H المجلد HALEMOO غيره فى الكود الى المسار الذى تفضله يعنى تعمل مجلد اسمه HALEMOO فى الـــــــ H ,شغل الكود هتلاقى هناك ملف جديد كل فتره زمنية رابعا ان أعجبك المرفق حدد الاجابة كأفضل اجابة عشان متزعلش الأستاذ ياسر تحياتى Auto Save Workbook after x time by mokhtar for halemoooooooo.rar

لا أستطيع الرد الا اذا رأيت الملف لكن انظر الى الكود Sub GetData_Example1() ' السطر الاول بنقول للكود هات البيانات من الملف المغلق الفلانى/ الشيت الفلانى ' السطر الذى يليه بنقول للكود انسخ المدى الفلانى من الشيت الفلانى 'وكمان الصق الكلام ده فى الخليه الفلانيه GetData ThisWorkbook.Path & "\mokhtar1.xls", "Sheet1", _ "A1:C5", Sheets("Sheet1").Range("AA1"), True, True ActiveWorkbook.Save Application.Quit End Sub فى السطر ده "A1:C5", Sheets("Sheet1").Range("AA1"), True, True تحديدا تأكد من الكلمتين True, True لو الثانية false غيرها الى True

حدد الاجابة التى تعجبك ليظهر الموضوع منتهى

السلام عليكم بعد اذن أخى وأستاذى ياسر جرب المرفق يا عمروووووووو أولا المجلد فى الــــ D حسب الكود يمكنك تغيير المسار الملف insert data in closed file اضغط الزر فقط كرر التجربة بس امسح اسم الشركة من ورقة فواتير فقط insert data in closed file.rar

جرب المرفق التالى يبدو أنك أخطأت فى نسخ الكود Facture.rar

جرب الكود ده Sub MOKHTAR_SaveAsPDF() Dim fName As String With Worksheets("Exemple facture chifrée") fName = ThisWorkbook.Name & .Range("C10").Value End With ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ "C:\Users\" & Environ("UserName") & "\Desktop\" & fName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End Sub الملف هيكون اسمه باسم الملف والخلية C10 تحياتى

تفضل يا أبو سليمان بعد فك الضغط عن المرفق سوف تجد ملفاً باسم الرئيسية ضعه فى المجلد mokhtar get data for bosoliman كن حذرا مع الملف إذ به معادلات واحتفظ بالملف المضغوط كنسخة احتياطية الشرح بعد ما تبدى رأيك تحياتى الرئسية.rar

السلام عليكم انتظرتى شوية يا بوسليمان الملف جاهز تماما لا تقلق ساعة و الملف يكمل بأذن الله

نوعية فورمات للتاريخ

وحضرتك بتقول أنك ما تعرفش تسوق !!!! ما شاء الله عليك أستاذ مجدى فنان والله بجد واضافة حضرتك سوف أحتفظ بها ما دمتُ حياً أبو نبأ ربنا يبارك فيك شرفت الموضوع

أبوسليمان فى هذا المرفق تم تغيير امتداد الملفات الستة الى xls مع تغيير أسماء الملفات لسهولة التعامل جلبت لك البيانات من الملفات الخمس وهى مغلقة وبضغطة واحدة الى ملف الرئيسية تحديث البيانات : عدل كما تشاء فى الملفات الخمس وانقر على الزر فى الرئيسية فقط وبكده نكون عملنا المرحلة الأولى أما الثانية سوف أسألك بعض الأسئلة فى حينها أما السؤال الأن : الرقم الطويــــــــــــــــــــــــــــــــــــــــــــــل ده بيتقسم الى خلايا هل المطلوب منه أن نستخلص منه تاريخ ووقت مثلاً ؟ أرجو الايضاح وسوف نكمل الموضوع باذن الله تعالى mokhtar get data for bosoliman.rar

أخى سليمان سوف أطلع على الرابط أخى عمرو أكرمك الله مختار 1 زى مختار 2 زى مختار 3 .....مختار 10000.الخ كلها ملفات مغلقة والسلام بها بيانات ونحن بنجمع البيانات منها ونحطها فى ملف واحد مغلق نسمية مختار نسميه عمرو نسميه ملف التجميع أى شىء من ذلك أرجو أن تكون الفكرة وصلت

فعلا أستاذ محمد لدى خطأ صححنه و اجايتك ممتازة الأخ احمد الشهور الهجرية 29 و 30 الشهور الميلادية 28 و29 و30 و31 وده بيعمل لخبطة فى النتائج قارن بين النتائج و شوف الذى يعطيك نتائج صحيحة تحياتى

الأستاذ الفاضل محمد بارك الله فيكم فى مرفق حضرتكم ماذا لو أضفنا 60 يوما بدل 20 الناتج لا يكون صحيحا يمكن التغلب على ذلك بالملف التالى add-in بعد اضافة المرفق يا أحمد الى الاكسل لما تفتح دوال اليوم والتاريخ هتلاقى دوال اضافية الدوال الجديدة 1 XDATE كتابة تاريخ 2 XDATEADD اضافة عدد من الأيام على تاريخ ( الدالة دى بتاعتك هى التى تستخدمها ) 3 XDATEDIF لحساب عدد الأيام بين تاريخين 4 XDATEYEARDIF لحساب عدد السنوات بين تاريخين 5 XDATEYEAR معرفة رقم السنة فى التاريخ 6 XDATEMONTH معرفة رقم الشهر فى التاريخ 7 XDATEDAY معرفة رقم اليوم فى التاريخ 8 XDATEDOW معرفة اسم اليوم فى التاريخ 1 الاحد 2 الاثنين 3 الثلاثاء 4 الاربعاء 5 الحميس 6 الجمعة 7 السبت طريقة الاضافة : ملف خيارات add-in ثم go تم browse ثم ابحث عنها فى مسارها وحددها واضغط موافق سوف تجد الدوال الحديتة ضمن دوال اليوم والتاريخ دعواتك ليه بقى وتفضل المرفق xdate.zip

معلش يا عمرو انشغلت شويه عنك هل تقصد أنك تريد أن تنسخ بيانات من عدد كبير من الملفات المغلقة GetData ThisWorkbook.Path & "\mokhtar3.xls", "Sheet1", _ "E1:E23", Sheets("Sheet1").Range("E1"), True, True 'وبنفس الكيفية يمكنك زيادة عدد الملفات المغلقة الجزء ده كرره فى الكود زى ما أنت عايز مع أى عدد من الملفات المغلقة التى تريد النسخ منها غير اسم الملف واسم الشيت والمدى المنسوخ

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

السلام عليكم أحمد جرب ده مؤقتاً الناتج بيظهر فى رسالة Sub adddaystodate() Dim UserResp As String Dim myDate As Date Dim numDays As Double UserResp = InputBox("أدخل التاريخ من فضلك ") numDays = InputBox("كم يوما تريد اضافتها للتاريخ ؟") myDate = CDate(UserResp) MsgBox DateAdd("d", numDays, myDate) End Sub تحياتى