اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

ahmedabuzena

بواسطه ahmedabuzena
في منتدى الاكسيل Excel

 مشاركة
إذهب إلى أفضل إجابة Solved by محمد هشام.,

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

محمد هشام.

محمد هشام.

قام بنشر
قام بنشر

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

رغم انه في وجهة نظري ان الاقتراح المقدم من اخينا @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

  • Like 3
رابط هذا التعليق
شارك
  • أفضل إجابة
محمد هشام.

محمد هشام.

قام بنشر
  • أفضل إجابة
قام بنشر (معدل)

جرب هدا  

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

تم تعديل بواسطه محمد هشام.
  • Like 2
رابط هذا التعليق
شارك
ahmedabuzena

ahmedabuzena

قام بنشر
  • الكاتب
قام بنشر
1 ساعه مضت, محمد هشام. said:

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

Capture.PNG.48b307e8f0844ee2ebec86ab4cdf2b58.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 "يرجى ادخال التاريخ", 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

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

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

رابط هذا التعليق
شارك
ahmedabuzena

ahmedabuzena

قام بنشر
  • الكاتب
قام بنشر
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

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

 

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 50.5 kB · 4 downloads

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

رابط هذا التعليق
شارك
AbuuAhmed

AbuuAhmed

قام بنشر
قام بنشر (معدل)

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

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

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

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

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

محمد هشام.

قام بنشر
قام بنشر
في 16‏/8‏/2024 at 08:52, AbuuAhmed said:

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

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

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

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

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

 

 

 

 

 

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept