ادراج جميع ايام الشهر بمجرد اختيار الشهر

ahmedabuzena · أغسطس 15

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

SHADY TIME TABLE 1.xls

**AbuuAhmed** · أغسطس 15

فقط أدخل تاريخ الشهر في الخلية "I4"

SHADY TIME TABLE 1_01.xls

تم تعديل أغسطس 15 بواسطه AbuuAhmed
تنقيح المرفق

**محمد هشام.** · أغسطس 15

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

رغم انه في وجهة نظري ان الاقتراح المقدم من اخينا @AbuuAhmed افضل واسهل وينفد المطلوب دون الحاجة لاستخدام صندوق الادخال

في حالة كانت لك رغبة لاستخدام نفس الطريقة يمكنك تجربة هدا

Sub my_date()
Dim xDate As String, i As Long
Set sh = Sheets("ELRASHIDY")
xDate = InputBox("insert date format month/year ", "insert month date", "MM/YYYY")
   
   If StrPtr(xDate) = 0 Then Exit Sub
    If Not IsDate(xDate) Or Not (xDate) Like "##/####" Then _
     MsgBox "يرجى التحقق من تاريخ الادخال", vbExclamation: Exit Sub
     
Application.ScreenUpdating = False

With sh
.Range("B6:C36,N6:O36").ClearContents
   tmp = DateSerial(Year(xDate), _
      Month(xDate) + 1, 1) - DateSerial(Year(xDate), Month(xDate), 1)
      Range("B6,N6,I4").Value = DateSerial(Year(xDate), Month(xDate), 1)
      [B6].AutoFill Destination:=[B6].Resize(tmp), Type:=xlFillDays
      [N6].AutoFill Destination:=[N6].Resize(tmp), Type:=xlFillDays

For i = 6 To sh.Cells(Rows.Count, "b").End(xlUp).row
    ColDates = Range("b" & i).Value
    DayName = Format(ColDates, "dddd")
        With Union(sh.Range("C" & i), sh.Range("O" & i))
           .Value = DayName
        End With
      Next i
 End With
Application.ScreenUpdating = True
End Sub

SHADY TIME TABLE 1_V2.xls

mahmoud nasr alhasany · أغسطس 15

احسنت استاذنا / محمد هشام.

احسنت استاذنا / AbuuAhmed .

ahmedabuzena · أغسطس 15

ما شاء الله مش اختار مين افضل اجابة الاثنين افضل من بعض جزاكم الله خيرا

عندي استفسار ليه في الطباعة بيظهر اول جدول فقط

**محمد هشام.** · أغسطس 15

جرب هدا

Sub Print_Tbl()
Dim lr As Long
Set WS = Sheets("ELRASHIDY")
Application.ScreenUpdating = False
With WS
.ResetAllPageBreaks
lr = WS.Columns("B:X").Find(What:="*", _
SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Application.PrintCommunication = False
With WS.PageSetup
        .PrintArea = WS.Range("B2:X" & lr).Address
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
End With
    Application.PrintCommunication = True
    Application.ScreenUpdating = True
    ActiveWindow.SelectedSheets.PrintPreview
    'WS.PrintOut Copies:=1
End Sub

اخي لقد حاولت حدف الاعمدة الغير مستخدمة مما سيجبرني على تعديل الكود السابق بما يناسب التصمييم الجديد

Capture2.PNG.e7d237419d58c3d616b83acb797dd2c8.PNG

Sub my_date()
Dim xDate As String, i As Long
Set sh = Sheets("ELRASHIDY")
  Do
xDate = InputBox("insert date format month/year ", "insert month date", "MM/YYYY")
 
If StrPtr(xDate) = 0 Then Exit Sub
    If xDate = "MM/YYYY" Then MsgBox "يرجى ٌإدخال التاريخ", 48
Loop While xDate = "MM/YYYY"
   
    If Not IsDate(xDate) Or Not (xDate) Like "##/####" Then _
     MsgBox "يرجى التحقق من التاريخ", 16: Exit Sub
    
Application.ScreenUpdating = False
With sh
    .Range("A6:B36,I6:J36").ClearContents
     cnt = DateSerial(Year(xDate), Month(xDate), 1)
          arr = Array("A6", "I6", "G4", "O4")
              tmp = DateSerial(Year(xDate), _
                   Month(xDate) + 1, 1) - cnt
        For i = LBound(arr) To UBound(arr)
             .Range(arr(i)).Value = cnt
        Next i
    [A6].AutoFill Destination:=[A6].Resize(tmp), Type:=xlFillDays
    [I6].AutoFill Destination:=[I6].Resize(tmp), Type:=xlFillDays
    
For i = 6 To sh.Cells(Rows.Count, "A").End(xlUp).Row
    ColDates = Range("A" & i).Value
    DayName = Format(ColDates, "dddd")
       With Union(sh.Range("B" & i), sh.Range("J" & i))
          .Value = DayName
       End With
    Next i
 End With
Application.ScreenUpdating = True
End Sub

Sub PrintTb2()
Dim lr As Long
Set WS = Sheets("ELRASHIDY")
With WS
.ResetAllPageBreaks
lr = .Cells(.Rows.Count, "a").End(xlUp).Row
Application.PrintCommunication = False
With WS.PageSetup
        .PrintArea = WS.Range("A2:O" & lr).Address
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    Application.PrintCommunication = True
    WS.PrintPreview
   'WS.PrintOut Copies:=1
   End With

End Sub

SHADY TIME TABLE 1_V4.xls

تم تعديل أغسطس 16 بواسطه محمد هشام.

ahmedabuzena · أغسطس 15

1 ساعه مضت, محمد هشام. said:

اخي لقد حاولت حدف الاعمدة الغير مستخدمة مما سيجبرني على تعديل الكود السابق بما يناسب التصمييم الجديد

Sub my_date()
Dim xDate As String, i As Long
Set sh = Sheets("ELRASHIDY")
Do
xDate = InputBox("insert date format month/year ", "insert month date", "MM/YYYY")
 
 If StrPtr(xDate) = 0 Then Exit Sub
    If xDate = "MM/YYYY" Then MsgBox "يرجى ادخال التاريخ", vbExclamation
Loop While xDate = "MM/YYYY"
    
    If Not IsDate(xDate) Or Not (xDate) Like "##/####" Then _
     MsgBox "يرجى التحقق من تاريخ الادخال", vbExclamation: Exit Sub
     
Application.ScreenUpdating = False
With sh
.Range("a6:b36,h6:i36").ClearContents
 r = DateSerial(Year(xDate), Month(xDate), 1)
 arr = Array("A6", "H6", "G4") ', "N4"
   tmp = DateSerial(Year(xDate), _
      Month(xDate) + 1, 1) - r
   For i = LBound(arr) To UBound(arr)
    .Range(arr(i)).Value = r
   Next i
   
      [A6].AutoFill Destination:=[A6].Resize(tmp), Type:=xlFillDays
      [H6].AutoFill Destination:=[H6].Resize(tmp), Type:=xlFillDays

For i = 6 To sh.Cells(Rows.Count, "A").End(xlUp).Row
    ColDates = Range("A" & i).Value
    DayName = Format(ColDates, "dddd")
        With Union(sh.Range("B" & i), sh.Range("I" & i))
           .Value = DayName
        End With
      Next i
 End With
Application.ScreenUpdating = True
End Sub

Sub Impression()
Application.ScreenUpdating = False
Set WS = Sheets("ELRASHIDY")
WS.ResetAllPageBreaks
lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
ColFin = [1:14].Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column
WS.PageSetup.PrintArea = Range("A1", Cells(lr, ColFin)).Address
   WS.PrintPreview
   'WS.PrintOut Copies:=1
    Application.ScreenUpdating = True
End Sub

SHADY TIME TABLE 1_V3.xls 50.5 kB · 1 download

الغرض من عمل جدولين اني عايز اطبع ورقة واحدة بها جدولين وبعدين افصل الجدولين عن بعض

بس كدة لو حاولت افصل الجدولين حافظه البيانات المكتوبة اعلى جدول رقم واحد

**محمد هشام.** · أغسطس 15

اخي @ahmedabuzena تم تعديل الكود و اظافة عمود فارغ بين الجداول في المشاركة السابقة

تم تعديل أغسطس 16 بواسطه محمد هشام.

ahmedabuzena · أغسطس 16

8 ساعات مضت, محمد هشام. said:

جرب هدا

Sub Print_Tbl()
Dim lr As Long
Set WS = Sheets("ELRASHIDY")
Application.ScreenUpdating = False
With WS
.ResetAllPageBreaks
lr = WS.Columns("B:X").Find(What:="*", _
SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Application.PrintCommunication = False
With WS.PageSetup
        .PrintArea = WS.Range("B2:X" & lr).Address
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
End With
    Application.PrintCommunication = True
    Application.ScreenUpdating = True
    ActiveWindow.SelectedSheets.PrintPreview
    'WS.PrintOut Copies:=1
End Sub

اخي لقد حاولت حدف الاعمدة الغير مستخدمة مما سيجبرني على تعديل الكود السابق بما يناسب التصمييم الجديد

Sub my_date()
Dim xDate As String, i As Long
Set sh = Sheets("ELRASHIDY")
  Do
xDate = InputBox("insert date format month/year ", "insert month date", "MM/YYYY")
 
If StrPtr(xDate) = 0 Then Exit Sub
    If xDate = "MM/YYYY" Then MsgBox "يرجى ٌإدخال التاريخ", 48
Loop While xDate = "MM/YYYY"
   
    If Not IsDate(xDate) Or Not (xDate) Like "##/####" Then _
     MsgBox "يرجى التحقق من التاريخ", 16: Exit Sub
    
Application.ScreenUpdating = False
With sh
    .Range("A6:B36,I6:J36").ClearContents
     cnt = DateSerial(Year(xDate), Month(xDate), 1)
          arr = Array("A6", "I6", "G4", "O4")
              tmp = DateSerial(Year(xDate), _
                   Month(xDate) + 1, 1) - cnt
        For i = LBound(arr) To UBound(arr)
             .Range(arr(i)).Value = cnt
        Next i
    [A6].AutoFill Destination:=[A6].Resize(tmp), Type:=xlFillDays
    [I6].AutoFill Destination:=[I6].Resize(tmp), Type:=xlFillDays
    
For i = 6 To sh.Cells(Rows.Count, "A").End(xlUp).Row
    ColDates = Range("A" & i).Value
    DayName = Format(ColDates, "dddd")
       With Union(sh.Range("B" & i), sh.Range("J" & i))
          .Value = DayName
       End With
    Next i
 End With
Application.ScreenUpdating = True
End Sub

Sub PrintTb2()
Dim lr As Long
Set WS = Sheets("ELRASHIDY")
With WS
.ResetAllPageBreaks
lr = .Cells(.Rows.Count, "a").End(xlUp).Row
Application.PrintCommunication = False
With WS.PageSetup
        .PrintArea = WS.Range("A2:O" & lr).Address
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    Application.PrintCommunication = True
    WS.PrintPreview
   'WS.PrintOut Copies:=1
   End With

End Sub

SHADY TIME TABLE 1_V4.xls 50.5 kB · 4 downloads

جزاكم الله خيرا

**AbuuAhmed** · أغسطس 16

هذا الموضوع به مخالفة لقوانين المنتدى

ابتدأ بطلب توزيع أيام الشهر وتم حلها من أول إجابة.

ثم تم طلب حل مشكلة طباعة لم تذكر في الطلب منذ البداية أي بمثابة سؤال جديد منفصل.

فالمفاضلة التي تمت ليس لها علاقة بالسؤال والخطأ هنا مشترك من السائل ومن زميلي ومن الإشراف الذي لم يتدخل.

تم تعديل أغسطس 16 بواسطه AbuuAhmed
تعديل خطأ مطبعي

**محمد هشام.** · أغسطس 17

في 16‏/8‏/2024 at 08:52, AbuuAhmed said:

فالمفاضلة التي تمت ليس لها علاقة بالسؤال والخطأ هنا مشترك من السائل ومن زميلي ومن الإشراف الذي لم يتدخل

صراحة استاذ أحمد أنا لم أقصد فأنا من أول مشاركة لي أشرت ان الكود الخاص بك في وجهت نظري هو الأفضل ليبقى للسائل إختيار ما يناسبه

أما بخصوص الطلب الثاني وهو تنسيق الطباعة قمت بالجواب عنه عند ذكره عدم إختيار أفضل إجابة لأنه بالنسبة له سواء. فقط

فهدفنا ليس الحصول او التنافس على نيلها و أعتقد أنك كذلك تشاطرنني نفس الرأي .

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

تسجيل الدخول

ادراج جميع ايام الشهر بمجرد اختيار الشهر

الردود الموصى بها

ahmedabuzena

AbuuAhmed

محمد هشام.

mahmoud nasr alhasany

ahmedabuzena

محمد هشام.

ahmedabuzena

محمد هشام.

ahmedabuzena

AbuuAhmed

محمد هشام.

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information