نجوم المشاركات

Sub ImporterExcelPartirWord() 'Déclarez les variables Object pour l'application et le document Word. Dim WordApp As Object, wddoc As Object 'Déclarez une variable String pour le nom du document d'exemple et le chemin du dossier. Dim strDocNom As String 'L'instruction On Error si Word n'est pas déjà ouvert. On Error Resume Next 'Activer Word s'il est déjà ouvert. Set WordApp = GetObject(, "Word.Application") If Err.Number = 429 Then Err.Clear 'Créez une application Word si Word n'est pas déjà ouvert. Set WordApp = CreateObject("Word.Application") End If 'Assurez-vous que l'application Word est visible. WordApp.Visible = True 'Définissez la variable de chaîne strDocName. strDocNom = "C:\mesfichiers\monDocWord.docx" 'Activez l'application Word. WordApp.Activate 'Définissez la variable objet pour le nom complet du document Word et le chemin d'accès au dossier. Set worddoc = WordApp.Documents(strDocNom) 'Si le document Word n'est pas déjà ouvert, ouvrez-le. If worddoc Is Nothing Then Set worddoc = WordApp.Documents.Open(strDocNom) 'Le document est ouvert, alors activez-le. worddoc.Activate 'Copier le paragraphe 2 worddoc.Paragraphs(2).Range.Copy 'Activez votre classeur et collez le texte copié dans la cellule active. ThisWorkbook.Activate 'Collez le paragraphe 2 du document Word. ActiveSheet.Paste 'Fermez le document Word, pas besoin d'enregistrer les modifications. worddoc.Close Savechanges:=False 'Quittez l'application Word. WordApp.Quit 'Libérez la mémoire système réservée aux deux variables Object. Set worddoc = Nothing Set WordApp = Nothing End Sub

السلام عليكم اعضاء الكنترول الكرام اضع بين ايديكم شيت كنترول جدارات _ قسم حاسبات " الصف الاول "_ مفتوح المصدر يشتمل على ♦ شيت الرصد ♦ شهادات التيرم الاول ♦ شهادات نهاية العام ♦ تحديد الاوائل في الشهادة " هذا العمل خالصا لوجه الله تعالى " hasbat_1_gdarat.xlsm

هذا الحل نموذجي ويحقق المطلوب 100% يجب ان تتأكد انا جربت الكود يعمل على احسن وجه اذا الايام 30 يجعلها صفر ويزيد 1 للشهور واذا كانت اقل يبقيها كما هي واليك التطبيق db1.accdb

من المفروض ارفاق الملف في اول مرة بنفس تنسيق الملف الاصلي اخي سعد هناك بعض الاخطاء البسيطة على ملفك تسببت في عدم تنفيد الكود بالشكل الصحيح 1) عدم تطابق الاسماء في رؤوس اعمدة المواد والقائمة المنسدلة 2) لم تقم بتغيير عمود لصق البيانات ليتوافق مع الشكل الجديد ' لصق بعد اخر خلية من عمود (AG) desWS.Cells(Rows.Count, 33).End(xlUp).Offset(1).PasteSpecial xlPasteValues Or desWS.Cells(desWS.Rows.Count, "AG").End(xlUp).Offset(1).PasteSpecial xlPasteValues مع تفريغه في اول الكود بالشكل التالي لكي لا يتم نسخ البيانات تحت بعضها البعض desWS.Range("AG13:AG" & Rows.Count).ClearContents وفي حدث ورقة saad Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Select Case Target.Address(0, 0) Case "Y7": Call CopyData2: Case "AF8": Call CopyData2 Target.Select Case Else: Exit Sub End Select End Sub eman v2.xlsm

تأييداً لكلام الأستاذ @kkhalifa1960 ، أرجو تجربة التعديل بهذا الكود ، Private Sub Calc_Click() نص3 = DateAdd("d", DateDiff("d", [بداية العمل], [نهاية العمل]) / 2, [بداية العمل]) Dim startDate As Date Dim endDate As Date Dim years As Integer Dim months As Integer Dim days As Integer startDate = [بداية العمل] endDate = [نهاية العمل] years = DateDiff("yyyy", startDate, endDate) months = DateDiff("m", DateAdd("yyyy", years, startDate), endDate) days = DateDiff("d", DateAdd("m", months, DateAdd("yyyy", years, startDate)), endDate) If Day(endDate) < Day(startDate) Then months = months - 1 days = DateDiff("d", DateAdd("m", months, DateAdd("yyyy", years, startDate)), endDate) End If If Month(endDate) < Month(startDate) Then months = 12 + Month(endDate) - Month(startDate) End If If Day(startDate) = Day(endDate) + 1 Then days = 0 End If Dim result As String result = years & " سنة " & months & " شهر " & days & " يوم" نص5 = result نص10 = days نص12 = months نص14 = years End Sub

استاذ @moho58 يتم حساب فروق الأشهر هنا على أساس شهري، وليس حسب شهر التقويم كما هو الحال مع الدالة DateDiff. لما لها من اخطاء وثغرات .

Sub Test() Dim lr As Long, r As Range Dim ws As Worksheet: Set ws = Worksheets("واجهة") Dim Wdst As Worksheet: Set Wdst = Worksheets("مبيعات") Const Check = "A13:C13": Set r = ws.Range(Check): Rng = ws.[A3:AA13].Value lr = Wdst.Cells(Rows.Count, 3).End(xlUp).Row + 1 If Application.WorksheetFunction.CountA(r) < r.Count Then MsgBox "برجاء اكمال البيانات", vbExclamation, "كود الترحيل " Exit Sub Else Wdst.Range("A" & lr).Resize(UBound(Rng), UBound(Rng, 2)).Value2 = Rng ws.[A13:AA13] = Empty MsgBox "تم بنجاح", vbInformation, "كود الترحيل " End If End Sub ترحيل1 V1.xlsm

- قف على أي خلية بها رقم وانسخ الفاصلة العشرية - ظلل عمود الأرقام - اعمل عملية استبدال للكل من صندوق البحث بعد لصق الفاصلة المنسوخة وفي صندوق النص البديل ضع الفاصلة حسب قسم الأرقام من لوحة المفاتيح. ستتحول كل البيانان النصية إلى رقمية وستضطر إلى عملية تنسيق رقمي للعمود. أو استخدم هذه الشفرة: Sub Macro1() Sheets("101").Select If Asc(Mid(Range("C2"), Len(Range("C2")) - 2, 1)) <> 63 Then MsgBox "يبدو أنه قد تمت المعالجة من قبل" Exit Sub End If Columns("C:C").Select Selection.Replace What:=Mid(Range("C2"), Len(Range("C2")) - 2, 1), Replacement:=".", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Selection.NumberFormat = "#,##0.00" MsgBox "Done" End Sub

وجزاكم بمثل ما دعوتم آمين الحمد لله الذي بنعمته تتم الصالحات والله ولي التوفيق

وعليكم السلام تفضل أخي الكريم Book2.xlsx

بارك الله فيك أخي @أبومروان وجزاكم مثله اخى الغالي @محمد يوسف ابو يوسف بارك الله فيك اخى @hafez81 بارك الله فيك أخي @Yasser Fathi Albanna وجزاكم الله خيرا اخوتى على دعواتكم وعلى مروركم العطر