اذهب الي المحتوي
أوفيسنا

محمد عبد الناصر

04 عضو فضي
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    600

  • تاريخ الانضمام

  • تاريخ اخر زياره

 نوع المحتوي 

مشاركات المكتوبه بواسطه محمد عبد الناصر

    مساعده في كود ارتباط تشعبي

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه محمد عبد الناصر

    هذا الكود يقوم بربط الشيتات ب Sheet1

    اريد ان يقوم بعمل الكود وان لا ينفذ الامر على sheet2 و sheet7 و sheet3

    وان يجعل حجم الخط في الخليه E1 في كل الشيتات 30  

    Sub ww()


Dim h As Worksheet, sh As Worksheet, j As String
Dim k As String, x As String, d As String
Set h = Sheets("Sheet1")

For Each sh In Sheets
If Not sh.Name = "Sheet1" Then
j = sh.Index + 2
k = sh.Name
x = "'" & k & "'!a1"
d = "'Sheet1'!a1"
h.Hyperlinks.Add h.Cells(j, 1), "", x, k, k
sh.Hyperlinks.Add sh.Cells(1, 5), "", d, "Sheet1", "رجوع"
End If
Next

End Sub

     

    كود ترحيل الاسماء المستمرة و الاسماء التي خرجت والاسماء الجديدة في السنه الجديده

    في منتدى الاكسيل Excel

    قام بنشر

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

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

    ومطلوب كود اخر يقوم بتحديد الموظفين الذي تم زيادة رواتبهم والذي لم يتم زيادة رواتبهم في شيت المعدل 

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

    OK.xlsm

    تعديل على كود يقوم بفتح عدة شيتات

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه محمد عبد الناصر

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

    ولكن لماذا يقوم بمسح اي شيت اخر موجود فمثلا يقوم بمسح sheet2 وهو غير مكتوب في العمود C لا اريد ان يتم مسح اي شيت اخر عند تفعيل الكود

    تعديل على كود يقوم بفتح عدة شيتات

    في منتدى الاكسيل Excel

    قام بنشر

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

    في ها الكود يقوم بفتح عدة شيتات على حسب الاسم المكتوب في العمود C في كل خليه به

    المطلوب ان يقوم بنسخ البيانات وترحيلها الى الشيت المخصص لها حسب المكتوب في العمود C فمثلا في الخلية C4 مكتوب كنوز فيقوم بنسخ الصف الى شيت كنوز الخليه C5 مكتوب ادعية يقوم بنسخ الصف الى شيت ادعية 
    ومطلوب ان يجعل العمود B في كل الشيتات size 70 

    ويقوم ايضا بنسخ الصف 5 ويضعه في كل الشيتات في الصف رقم 5 

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

    Sub CreateSheets()
     
    Dim lra As Integer
    Dim My_Rg As Range
    Dim ListSh As Range
     lra = Cells(Rows.Count, "c").End(xlUp).Row

     Set ListSh = Worksheets("Sheet1").Range("c6:h" & lra)

     
    On Error Resume Next
    For Each My_Rg In ListSh
        If Len(Trim(My_Rg.Value)) > 0 Then
            If Len(Worksheets(My_Rg.Value).Name) = 0 Then
                Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = My_Rg.Value
            End If
        End If
      Worksheets("Sheet1").Select
    Next My_Rg
    
Applications.Calculations = xlCalculationManual
    
     End Sub

     

    اسلاميات.xlsm

    نقل اصفف وفتح شيت مخصص بشرط

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه محمد عبد الناصر

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

    مطلوب كود ييقوم بنقل اصفف حسب المكتوب في الخليه a1 في العمود E ويقوم بفتح شيت مخصص حسب الاسم المكتوب في العمود A3:A20000 

    الملف المرفق موضح الطلوب

    MD.xlsm

    فتح حماية الشيتات وقفل حماية الشيتات بباسورد

    في منتدى الاكسيل Excel

    قام بنشر

    20 دقائق مضت, lionheart said: 
    Sub Test()
    ProtectWorksheets False
        Rem YOUR CODE
    ProtectWorksheets True
End Sub

Public Sub ProtectWorksheets(ByVal bProtect As Boolean)
    Const MYPASS As String = "123"
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If bProtect = False Then
            ws.UnProtect Password:=MYPASS
        Else
            ws.Protect Password:=MYPASS
        End If
    Next ws
End Sub

     

    شكرا اخي الكريم جعله الله في موازين حسناتك

    • Like 1

    فتح حماية الشيتات وقفل حماية الشيتات بباسورد

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه محمد عبد الناصر

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

    مطلوب تعديل في هذا الكود 

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

    Sub go_mod5alat()

If Sheets("ÇáãÏÎáÇÊ").Range("c6") = "" Then MsgBox "ÏÎá ÇÓÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜã ÇáÚãããããíííííííííííííííííííááááááá", vbExclamation: Exit Sub
Sheets("ÝÇÊæÑÉ ãÏÎáÇÊ").PrintOut
Dim ws As Worksheet, Data As Worksheet, ShName As String
Dim LR As Long, ER As Long, x As Integer
Set Data = Sheets("ÇáãÏÎáÇÊ")
ShName = Data.Range("C6").Text

ER = Data.Range("B" & Rows.Count).End(3).Row
x = ER - 7
For Each ws In Worksheets
If ws.Name = ShName Then
LR = ws.Range("B" & Rows.Count).End(3).Row
ws.Name = ShName
ws.Range("B" & LR + 1).Resize(x, 17) = Data.Range("B10").Resize(x, 17).Value

End If
Next
Sheets("ÇáãÏÎáÇÊ").Protect Password:="20125907275"


Sheets("sheet1").Unprotect Password:="20125907275"
Dim strName As String, sh As Worksheet
    
    strName = Trim(Sheet4.Range("am14").Value)
    
    For Each sh In Worksheets
        If sh.Name = strName Then Exit Sub
    Next sh
    Sheet4.Copy after:=Sheets(Sheets.Count)
    Sheets("sheet1 (2)").Name = strName
    With Sheets(strName)
        .Shapes("Button 1").Delete
        With .Range("b10:am10000")
        .Value = .Value
       End With
       
    
 
Sheets("ÇáãÏÎáÇÊ").Range("B10:B1000").ClearContents
Sheets("ÇáãÏÎáÇÊ").Range("d10:d1000").ClearContents
Sheets("ÇáãÏÎáÇÊ").Range("h10:h1000").ClearContents
Sheets("ÇáãÏÎáÇÊ").Range("n10:n1000").ClearContents
Sheets("ÇáãÏÎáÇÊ").Range("c6").ClearContents
Sheets("ÇáãÏÎáÇÊ").Protect Password:="20125907275"
Sheets("ÇáãÏÎáÇÊ").Select
    Range("A1").Select

    ActiveWorkbook.Save
End Sub

     

    اخفاء مسميات الصفوف والاعمدة مساعدة

    في منتدى الاكسيل Excel

    قام بنشر

    4 دقائق مضت, محمد حسن المحمد said:

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

    يمكنك الاستعانة بهذا الكود في السطر الرابع تلغي تفعيل إظهار رؤوس الصفوف والأعمدة

    والسلام عليكم

    image.png.fc00c532103ae5fad79d8bb3b279effc.png 

    Private Sub Workbook_Open()
ThisWorkbook.Application.WindowState = xlMaximized
ThisWorkbook.Application.DisplayFullScreen = True
ActiveWindow.DisplayHeadings = False
Application.DisplayFormulaBar = False
End Sub

     

    ماشاء الله اخي الكريم هو المطلوب تمام شكرا لك وبارك الله لك

    • Like 1

    كود فتح ورقه جديدة بالاسم المكتوب في خلية محدده (طلب تعديل )

    في منتدى الاكسيل Excel

    قام بنشر

    7 دقائق مضت, محي الدين ابو البشر said: 
     

    هذا الكود يقوم بتفح ورقة جديدة على حسب المكتوب في AM14 

    المطلوب ان يقوم بقفل و حماية هذه الورقة الذي يقوم بفتحها لعدم العبث او تخريب البيانات بها 

    Sub CopySheet()
    Dim strName As String, Sh As Worksheet
    strName = Trim(Sheet4.Range("am14").Value)
    
    For Each Sh In Worksheets
        If Sh.Name = strName Then Exit Sub
    Next Sh
    Sheet4.Copy after:=Sheets(Sheets.Count)
     ActiveSheet.Name = strName
    ActiveSheet.Protect "password" ' ضع كلمة السر بدل password
    With Sheets(strName)
        .Shapes("Button 1").Delete
        With .Range("b10:am1009")
        .Value = .Value
       End With
    End With
     Sheets("الشاشة الرئيسية").Select
    Range("A1").Select
End Sub

     

    ماشاء الله استاذ محي الدين بارك الله فيك وفي علمك وجزاك كل خير

    كود فتح ورقه جديدة بالاسم المكتوب في خلية محدده (طلب تعديل )

    في منتدى الاكسيل Excel

    قام بنشر

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

    هذا الكود يقوم بتفح ورقة جديدة على حسب المكتوب في AM14 

    المطلوب ان يقوم بقفل و حماية هذه الورقة الذي يقوم بفتحها لعدم العبث او تخريب البيانات بها 

    Sub CopySheet()
    Dim strName As String, Sh As Worksheet
    strName = Trim(Sheet4.Range("am14").Value)
    
    For Each Sh In Worksheets
        If Sh.Name = strName Then Exit Sub
    Next Sh
    
    Sheet4.Copy after:=Sheets(Sheets.Count)
    Sheets("sheet1 (2)").Name = strName
    With Sheets(strName)
        .Shapes("Button 1").Delete
        With .Range("b10:am1009")
        .Value = .Value
       End With
    End With
     Sheets("الشاشة الرئيسية").Select
    Range("A1").Select
End Sub

     

    كود ايقاف عمل الكود اذا كانت الخلية فارغة

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه محمد عبد الناصر

    في 1‏/3‏/2023 at 17:01, lionheart said:

    What's the error message

     

    Try using one condition only 

    If ShName = "" Then MsgBox "Cell Is Empty", vbExclamation: Exit Sub

     

    اريد اضافة البحث اولا في شيت المدخلات فهكذا يكون ؟ 

    If Sheets("المدخلات").Range("c6") = "" Or IsEmpty(ShName) Then MsgBox "دخل اسم العمممممييييييللللللل", vbExclamation: Exit Sub

     

    كود ايقاف عمل الكود اذا كانت الخلية فارغة

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه محمد عبد الناصر

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

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

    Sub go_mod5alat()
Sheets("المدخلات").Unprotect Password:="2020"
Dim ws As Worksheet, Data As Worksheet, ShName As String
Dim LR As Long, ER As Long, x As Integer
Set Data = Sheets("المدخلات")
ShName = Data.Range("C6").Text
ER = Data.Range("B" & Rows.Count).End(3).Row
x = ER - 7
For Each ws In Worksheets
If ws.Name = ShName Then
LR = ws.Range("B" & Rows.Count).End(3).Row
ws.Name = ShName
ws.Range("B" & LR + 1).Resize(x, 17) = Data.Range("B10").Resize(x, 17).Value
Sheets("المدخلات").Protect Password:="2020"
ActiveWorkbook.Save
End If
Next
End Sub

     

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

    في منتدى الاكسيل Excel

    قام بنشر

    6 دقائق مضت, ابراهيم الحداد said:

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

    استخدم الكود التالى 

    Sub GetInv()
Dim ws As Worksheet, Sh As Worksheet
Dim LR As Long, CuName As String
Dim Date1 As Date, Date2 As Date
Dim i As Long, p As Long
Set ws = Sheets("فاتورة تاريخ")
CuName = ws.Range("C1").Text
If CuName = Empty Then Exit Sub
Set Sh = Sheets(CuName)
Date1 = ws.Range("C2")
Date2 = ws.Range("C3")
ws.Range("A10").CurrentRegion.Offset(1, 0).ClearContents
LR = Sh.Range("M" & Rows.Count).End(3).Row
p = 9
i = 10
Do While i <= LR
If Sh.Cells(i, 13) >= Date1 And Sh.Cells(i, 13) <= Date2 Then
p = p + 1
Sh.Cells(i, 1).Resize(, 13).Copy
ws.Range("A" & p).PasteSpecial xlPasteValues
ws.Range("A" & p) = p - 9
End If
i = i + 1
Loop
Application.CutCopyMode = False
End Sub

     

    عندما تقوم بالرد علي في تعليق استاذ ابراهيم الحداد اعلم جيدا مهما كان طلبي فقد تم الحل قبل ان ارى اي شيء

    ماشاء الله بارك الله فيك وفي عقلك وعلمك اثابك الله 
     

    • Like 2

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

    في منتدى الاكسيل Excel

    قام بنشر

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

    مطلوب كود يقوم باستدعاء بيانات على حسب التاريخ المكتوب في شيت "فاتورة تاريخ" في الخلية c2 و c3 وعلى حسب اسم العميل المكتوب في الخلية C1 وان لا يقوم بالبحث في هذه الشيتات ( بيانات المخزن - المدخلات - المرتجع - sheet1 ) 

    فقط يقوم باستدعاء البيانات من اسم الشيت المكتوب في الخليه C1 على حسب الفترة المكتوبة في C2 و C3 في شيت "فاتورة تاريخ"

    الملف المرفق موضح المطلوب 

    استدعاء بيانات بالتاريخ.xlsm

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

    في منتدى الاكسيل Excel

    قام بنشر

    41 دقائق مضت, محي الدين ابو البشر said:

    ربما 

    Sub CopySheet()
    Dim strName As String, SH As Worksheet
    strName = Trim(Sheet4.Range("o14").Value)
    
    For Each SH In Worksheets
        If SH.Name = strName Then Exit Sub
    Next SH
    
    Sheet4.Copy after:=Sheets(Sheets.Count)
    Sheets("sheet1 (2)").Name = strName
    With Sheets(strName)
        .Shapes("Button 1").Delete
        With .Range("A10:Z400")
        .Value = .Value
       End With
    End With
     Sheets("sheet1").Select
    Range("A1").Select
End Sub

     

    استاذ محي الدين 
    كل الكلام لا يفي حقك ولا يشكرك على ما تفعله معي لا ارى ما يعطيك حقك الا الدعاء لك بان يرزقك الخيردائما اللهم اجعله في ميزان حسناتك 

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

    في منتدى الاكسيل Excel

    قام بنشر

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

    في هذا الكود يقوم بنسخ Sheet1 وفتح ورقة جديدة على حسب المكتوب في Sheet1 في الخلية O14 والكود يقوم بنقل البيانات التي في الورقة بدون اي دوال 

    المطلوب ان ينقل البيانات بدون دوال من العمود A10 الى Z400 وبقيت الخلايا يترك الدوال بداخلها 

    الملف المرفق موضح المطلوب  

    
Sub CopySheet()
    Dim strName As String, SH As Worksheet
    strName = Trim(Sheet4.Range("o14").Value)
    
    For Each SH In Worksheets
        If SH.Name = strName Then Exit Sub
    Next SH
    
    Sheet4.Copy after:=Sheets(Sheets.Count)
    Sheets("sheet1 (2)").Name = strName
    With Sheets(strName)
        .Shapes("Button 1").Delete
        .Cells.Copy
        .Cells.PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
    Sheets("sheet1").Select
    Range("A1").Select
End Sub

     

    نسخ الشيت.xlsm

    • Like 1

    تعديل على كود تجميع ارقام محددة من شيتات

    في منتدى الاكسيل Excel

    قام بنشر

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

    مطلوب التعديل على هذا الكود فهو يقوم بتجميع الارقام من العمود D8 ويضع الناتج في شيت "بيان الاربح" في العمود C5 ويقوم بتجميع الارقام من العمود F8 ويضع الناتج في "شيت الارباح" في العمود D5 ثم يقوم بعمليه حسابية الضرب ويظهر الناتج في العمود G8 على حسب اسم الصنف المكتوب في العمود B8 في شيت بيان الارباح

    المطلوب ان يقوم يتجميع الارقام من جميع الشيتات من العمود D10 ويضعها في شيت "بيان المخزن" في العمود D10 ويجمع الارقام من جميع الشيتات من العمود E10 ويضعها في العمود E10 في شيت " بيان المخزن"

    الكود يقوم بتجميع الارقام من كل الشيتات في الملف ما عدا شيتات محدده كما هو مذكور في الكود

    وان امكن ان يتم تطبيقه في الملف المرفق  

    Option Explicit

Sub test()
Dim a, x, w
Dim i&
Dim sht As Worksheet
x = Array("بيانات المخزن", "المدخلات", "مديونيات العميل", "المرتجع")
Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
With CreateObject("scripting.dictionary")
        For Each sht In ActiveWorkbook.Worksheets
             If IsError(Application.Match(sht.Name, x, 0)) Then
             a = sht.Cells(8, 1).Resize(sht.Cells(Rows.Count, 1).End(xlUp).Row - 7, 7)
                For i = 1 To UBound(a)
                    If Not .exists(a(i, 2)) Then
                 .Add a(i, 2), Array(a(i, 4), a(i, 3) * a(i, 4), a(i, 7))
            Else
         w = .Item(a(i, 2))
        w(0) = w(0) + a(i, 4): w(1) = w(1) + a(i, 3) * a(i, 4): w(2) = w(2) + a(i, 7)
        .Item(a(i, 2)) = w
        End If
            Next
        End If
    Next
For i = 5 To Range(Cells(5, 2), Cells(5, 2).End(xlDown)).Count
       If Cells(i, 2) = "" Then Exit Sub
    If Not .exists(Cells(i, 2)) Then Cells(i, 4).Resize(, 3) = .Item(Cells(i, 2).Value)
    Next
End With
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

     

     

    برنامج الترحيل.xlsm

×
×
  • اضف...

Important Information

  I accept