رجاء حل التاريخ المعكوس عند التصدير الى الوورد

[Alaa Ammar New]

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

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

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

جزاكم الله كل خير يا رب العالمين وزادكم بسطة في العلم والرزق والصحة آمين يا رب العالمين

2024 final.xlsm

تم تعديل يونيو 11 بواسطه Alaa Ammar New

[Saleh Ahmed Rabie]

2 ساعات مضت, Alaa Ammar New said:

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

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

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

جزاكم الله كل خير يا رب العالمين وزادكم بسطة في العلم والرزق والصحة آمين يا رب العالمين

2024 final.xlsm 246.98 kB · 1 download

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

**إصلاح تاريخ معكوس عند التصدير إلى Word

* **استخدم تنسيق التاريخ المخصص:**
  * في Excel، حدد الخلايا التي تحتوي على التاريخ.
  * انقر بزر الماوس الأيمن واختر "تنسيق الخلايا".
  * في علامة التبويب "الرقم"، حدد "مخصص" من القائمة المنسدلة "الفئة".
  * أدخل تنسيق التاريخ المطلوب، على سبيل المثال: "dd/mm/yyyy".

* **استخدم دالة TEXT:**
  * في Excel، أدخل الصيغة التالية في خلية فارغة:
  ```
 

=TEXT(A1, "dd/mm/yyyy")

  ```
  حيث A1 هي الخلية التي تحتوي على التاريخ المعكوس.* **استخدم ماكرو:**
  * يمكنك إنشاء ماكرو لتصحيح التاريخ المعكوس عند التصدير إلى Word.
  * افتح محرر Visual Basic (Alt + F11).
  * انقر على "إدراج" > "وحدة نمطية".
  * الصق الكود التالي في وحدة النمط:
  ```
 

Sub FixReversedDates()
    Dim rng As Range
    Dim cell As Range

    Set rng = Selection

    For Each ce=TEXT(A1, "dd/mm/yyyy")ll In rng
        If cell.NumberFormat = "@" Then
            cell.Value = DateValue(cell.Value)
        End If
    Next cell
  End Sub

  ```
 

[Alaa Ammar New]

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

حضرتك الكود بيدي خطأ

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

ربنا يكرم حضرتك يا رب

[محمد هشام.]

ضع الكود التالي في حدث ورقة Sheet1  سيتم تحديث التسلسل عند اظافة صف او حدفه .

وعند كتابة تاريخ جديد في عمود C

Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Integer, lastRow As Long
Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    Application.EnableEvents = False
    Application.ScreenUpdating = False
 
 With Target
    Select Case .Column
        Case 1, 3
            If .Row > 8 Then
  WS.Range("A9:A" & WS.Rows.Count).ClearContents
    lastRow = WS.Range("C" & WS.Rows.Count).End(xlUp).Row
        For I = 9 To lastRow
            WS.Range("A" & I).Value = Val(WS.Range("A8")) + I - 8
        Next I
    End If
    End Select
End With
   Application.ScreenUpdating = True
   Application.EnableEvents = True
End Sub

 اما بخصوص عكس التاريخ ليس له علاقة بالكود المشكلة عندك في تنسيق الملف  ان شاء الله اول ما اتفرغ ساحاول تعديل طريقة نسخ البيانات لتتناسب مع طلبك ادا لم يسبقني احد الاخوة في دالك

 

 

 

2024 final DATE.xlsm

تم تعديل يونيو 12 بواسطه محمد هشام.

[Alaa Ammar New]

أستاذنا القدير جام الكرم دائمًا في عون الناس ربنا يحفظك يا رب

منتظر تعديل سيادتك بالنسبة للتاريخ المعكوس عند التثدير للوورد في الوقت المتاح لحضرتك وجزاك الله خير الجزاء يا رب العالمين

 

[محمد هشام.]

تفضل اخي الكريم  

 

 

 

2024 final V2.xlsm

تم تعديل يونيو 12 بواسطه محمد هشام.

[Alaa Ammar New]

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

أخي في الله المحترم @محمد هشام. جزاك الله عنا خير الجزاء يارب العالمين ورزقك من واسع فضله وأنعم عليك بالصحة والستر ورزقك حجة إلى بيته المحرم يارب العالمين

جزيل الشكر لشخصكم الكريم متشكر جدا جدا جدا جدا ... زادك الله بسطة في العلم والرزق والصحة والستر.

[محمد هشام.]

في 13‏/6‏/2024 at 06:06, Alaa Ammar New said:

جزيل الشكر لشخصكم الكريم متشكر جدا جدا جدا جدا ... زادك الله بسطة في العلم والرزق والصحة والستر.

ولك بالمثل اخي 

 لقد لاحظت ان الاعمدة  الاخيرة تتضمن روابط المقاطع على اليوتيوب والفايس  اليك تحديث الكود لتتمكن من  نسخ  Hyperlinks المواقع والانتقال اليها عبر  الوورد 

Public Property Get n() As Worksheet: Set n = Worksheets("WordCopy")
End Property
   Sub Copy_Transfer_WORD1()
    Dim arr() As String: Dim cnt()  As String
    Dim lastRow As Long: Dim rngA As Variant: Dim rngB As Variant
    Dim OneRng As Range: Dim tmp As Range: Dim Ary As Variant
    Dim i As Long:   Dim r As Integer: Dim x As Long: Dim j As Range
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set WS = Worksheets("Sheet1")
    n.Visible = xlSheetVisible: n.Cells.UnMerge
    n.Range("A1:J" & n.Rows.Count).Clear
    lige = 7
    lastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
    cnt() = Split("I-H,J-I", ",")
    rngA = Array(1, 3, 4, 5, 6, 7, 8)
    rngB = Array(1, 2, 3, 4, 5, 6, 7)
    For i = 0 To UBound(rngA)
        With WS
            Set OneRng = .Range(.Cells(lige, _
            rngA(i)), .Cells(lastRow, rngA(i))).SpecialCells(xlCellTypeVisible)
            OneRng.Copy
            n.Cells(1, _
            rngB(i)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        End With
    Next i
      For r = 0 To UBound(cnt): arr = Split(cnt(r), "-")
 WS.Range(arr(0) & "8:" & arr(0) & lastRow).Copy Destination:=n.Cells(2, arr(1))
Next r
lr = n.Cells(n.Rows.Count, "A").End(xlUp).Row
Set tmp = n.Range("A1:J" & n.Rows.Count)
Set a = n.Rows(1): Set b = n.Rows(2): Set d = n.[A1:I1]: Set E = n.Range("A3:I" & lr)
   a.RowHeight = 75: a.Font.Bold = True: b.RowHeight = 40: b.Font.Bold = True: b.Font.Size = 14: d.Font.Size = 24
   d.Merge: d.Interior.Color = RGB(192, 192, 192): n.[A2:I2].Interior.Color = RGB(215, 238, 247)
With E
.Font.Name = "AdvertisingBold": .Font.Size = 13
    .WrapText = True: .MergeCells = False
End With
F = n.Cells(2, n.Columns.Count).End(xlToLeft).Column
n.Range(n.Cells(2, 1), n.Cells(lr, F)).Borders.Weight = xlThin
    Ary = Array(5, 15, 38, 38, 38, 15, 15, 15, 15)
        For x = 0 To UBound(Ary)
        n.Columns(x + 1).ColumnWidth = Ary(x)
 Next x
Set Irow = n.Range("A3", n.Cells(n.Rows.Count, "A").End(xlUp))
For Each j In Irow.Rows
        If j.RowHeight < 20 Then: j.RowHeight = 35: Else j.EntireRow.AutoFit
  Next
  With tmp
  .EntireColumn.HorizontalAlignment = xlCenter
  .EntireColumn.VerticalAlignment = xlCenter
  End With
With n.Range("A3:A" & n.Cells(Rows.Count, "B").End(xlUp).Row)
    .Value = Evaluate("ROW(" & .Address & ")-2")
End With
 WS.Activate: ExcelToWordSheet1
 n.Visible = xlSheetVeryHidden
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 End Sub

 

 

2024 final V3.xlsm

تم تعديل يونيو 14 بواسطه محمد هشام.

[Alaa Ammar New]

 

استاذي القدير @محمد هشام. وحضرتك طيب وبخير يارب العالمين

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

جزيل الشكر والتقدير لشخصك الكريم