اذهب الي المحتوي
محمد طاهر

كود لدمج محتويات عدة خلايا فى جدول ، و اضافة فاصلة بينها فى الخلية المدمجة

بواسطة محمد طاهر, في منتدي الوورد Word

Recommended Posts

محمد طاهر    1,745

محمد طاهر
قام بنشر

احتجت لدمج محتويات  عدد من الخلايا مع دمج محتوياتها فى كمية كبيرة من الجدوال ، مع اضافة فاصلة بين محتوياتها

فاعددت هذا الكود

اختر الخلايا المراد دمجها و دمج محتوياتها قبل تشغيل الكود

WordMergeTableWcomma.jpg.287b3471692b904f1b0673f78426b0a6.jpg 

Sub mergitwithcomma()

Selection.Cells.merge

       
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "، "
        
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
     
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    End Sub
لتنزل الملف

شارك هذه المشاركه

رابط المشاركه
شارك

مصطفى شاهين    46

مصطفى شاهين
قام بنشر

بارك الله فيك أستاذ محمد طاهر على جهودك الطيبة، والمعلومات القيِّمة التي تضيفها إلينا.

إن شاء الله في ميزان حسناتك

يعطيك ألف عافية

شارك هذه المشاركه

رابط المشاركه
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
الذهاب الي قائمه المواضيع

  • محتوي مشابه

    • gamalin
      الكلام العربي في الكود غير مفهوم
      بواسطه gamalin
      الاخوة الافاضل
      ارجوا سرعة الرد
      لدي ملف للتفقيط
      حاولت استخدامه مؤخرا في اكسل 2007 ووجدت الكلمات العربية غير مفهومة يرجى
      شرح كيف يمكن تعريبها او اذا كان الاكسل لدي ينقصه اي تعريف للغة
       
    • كريمو2
      ظهور رسالة الإقتطاع الشهري بشرط
      بواسطه كريمو2
      السلام عليكم احبتي مشرفي واعضاء المنتدى
      المطلوب التعدبل على الكود لكي يظهر الميساج مرة واحدة خلال كل شهر وبشرط وجود مبلغ إقتطاع
      واذا لم يكن وجود مبلغ الإقتطاع يظهر الميساح بعدم وجود الإقتطاع خلال هذا الشهر ويكون كذلك مرة واحدة كل شهر

       
      Private Sub cmd_Pay_installments_Click() On Error GoTo err_cmd_Pay_installments_Click Dim rst As DAO.Recordset 'Cridi and Elec Payments Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans Where [Payment_Month]=CDATE('" & Me.TxtMonth & "')") rst.MoveLast: rst.MoveFirst RC = rst.RecordCount a1 = 0 'just a flag a2 = 0 'jusf a flag If Len(rst!Payment_Made_Cridi & "") = 0 And Not IsNull(rst!Loan_Cridi) Then Select Case MsgBox(" هل تريد ان يتم توزيع الإقتطاعات لشهر" & Me.TxtMonth, vbYesNo + vbQuestion + vbDefaultButton1) Case vbYes For i = 1 To RC rst.Edit 'check, maybe a manual payment is done, so don't over write it 'If Len(rst!Payment_Made_Cridi & "") = 0 And Not IsNull(rst!Loan_Cridi) Then rst!Payment_Made_Cridi = rst!Loan_Cridi rst!sadad = rst!Loan_Cridi If rst!sadad.Value = True Then rst!wada3 = "تم التسديد" Else rst!wada3 = "لم يتم التسديد" End If TheSum = TheSum + Nz(rst!Payment_Made_Cridi, 0) + Nz(rst!Payment_Made_Elec, 0) + Nz(rst!Loan_Other, 0) 'a1 = 1 'End If 'If Len(rst!Payment_Made_Elec & "") = 0 And Not IsNull(rst!Loan_Elec) Then 'rst!Payment_Made_Elec = rst!Loan_Elec 'a1 = 1 'End If rst.Update rst.MoveNext Next i TheSum = Format(TheSum, "#,##0.00") MsgBox " " & "تم توزيع الإقتطاعات" & vbLf & vbLf & "مجموع الإقتطاعات = " & TheSum, , "إقتطاعات شهر" & FrenchMonth(Month(Date)) & Year(Date) Case vbNo MsgBox "لم يتم توزيع الإقتطاعات " End Select 'GoTo I_am_Done 'Other loans for, March (3) and July (7) If Month(Now()) = 3 Or Month(Now()) = 7 Then Dim rstE As DAO.Recordset Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans") myCriteria = "[detach]='موظف'" 'myCriteria = myCriteria & " Or [detach]='منتدب'" myCriteria = myCriteria & " Or [detach]='متعاقد كامل'" myCriteria = myCriteria & " Or [detach]='متعاقد جزئي'" myCriteria = myCriteria & " Or [detach]='عون نظافة'" Set rstE = CurrentDb.OpenRecordset("Select * From Employee Where " & myCriteria) rstE.MoveLast: rstE.MoveFirst RC = rstE.RecordCount For i = 1 To RC 'check if payment is already entered, if it is, then skip this Record rst.FindFirst "[Loan_Type]='Other' And [EmployeeID]=" & rstE!EmployeeID & " And [Payment_Month]=#" & Me.TxtMonth & "#" If rst.NoMatch Then rst.AddNew a2 = 1 rst!EmployeeID = rstE!EmployeeID rst!Loan_ID = 0 'rst!Loan_AwardMonth = Me.AwardMonth rst!Payment_Month = DateSerial(Year(Me.TxtMonth), Month(Me.TxtMonth), 1) 'rst!Loan_Cridi = Me.txtDiscountPerMonth 'rst!Loan_Elec= 'to be used in Elec loan Form rst!Loan_Other = 1100 'to be used in Other loan Form 'rst!Payment_Made = 'to be used each time a pyment is made rst!Loan_Type = "Other" rst!Remarks = "إقتطاع من الراتب لإشتراك شهر " & Year(Me.TxtMonth) & "/" & Month(Me.TxtMonth) rst.Update End If rstE.MoveNext Next i rstE.Close: Set rstE = Nothing End If I_am_Done: 'clean up rst.Close: Set rst = Nothing End If Exit Sub err_cmd_Pay_installments_Click: If Err.Number = 3021 Then 'No Records, ignore Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub  
    • Khalf
      إضافة ظل إلى نص برمجياً كود / أمر VBA
      بواسطه Khalf
      السلام عليكم
      أحتاج إلى أمر / كود فيجوال يمكنني من إضافة ظل إلى نص .
      خلال عملي لـ template في الوورد احتجت إلى هذا الأول و قد  بحثت و لم أجد إجابة واضحة 
      فلم أحصل على الطريقة الملائمة للاستفادة من الخاصية  
      .FONT.shadow بانتظار إسهاماتكم بارك الله بكم .
    • ياسر فاروق
      كود عملية ضرب
      بواسطه ياسر فاروق
      الساده
      السلام عليكم ورحمة الله وبركاته
      المرفق كود عمليه ضرب عمودين ووضع الناتج فى العمود الثالث من احد الساده الافاضل بالموقع
      وأريد شرح لخطوات الكود حتى أستطيع الاستفاده منه فى ملف أخر ولكن مسمى الأعمدة مختلفة
      Sub BOQ()
         
          For s = 1 To Sheets.Count
              Sheets(s).Select
              x = Cells.SpecialCells(xlCellTypeLastCell).Row
              For r = 8 To x
                  If IsNumeric(Cells(r, "I")) = False Then Cells(r, "F").FormulaR1C1 = "=RC[2]*RC[4]"
              Next r
          Next s
      End Sub
       
      وشكرا
    • AYMAN Z HARB
      كود فيجوال بيسك
      بواسطه AYMAN Z HARB
      السلام عليكم 
      هل يوجد حل لهذه المشكلة 
      مع العلم انها تظهر في ويندوز 10  وفي الاصدارات الاخرى لاتظهر 
      المشكلة في ملف عمل اكسيل 2003  و اكسيل 2010  نفس المشكلة 
      يرجى الافادة وشكرا 

  • المتواجدين الان   0 اعضاء متواجدين الان

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

×
×
  • اضف...