عبدالفتاح في بي اكسيل

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

اعلميني بالكودين ماذا يحدث معك قد استفيد منه بالمستقبل وباقي الاعضاء هذا تحديث اخر على حسب بياناتك Public Sub SendMails() Dim olApp As Object Dim newEmail As Object Dim sMsg As String Dim rng As Range Dim c As Range On Error Resume Next Set olApp = GetObject(, "Outlook.Application") On Error GoTo 0 If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application") End If With ThisWorkbook.Sheets("Sheet1") Set rng = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With For Each c In rng sMsg = c.Value2 & vbCrLf & _ c.Offset(, 1).Value2 & vbCrLf & _ c.Offset(, 2).Value2 & vbCrLf & _ c.Offset(, 3).Value2 & vbCrLf Set newEmail = olApp.CreateItem(0) With newEmail .To = c.Offset(, 4).Text .CC = "" .BCC = "" .Subject = "Subject" .Body = "Dear customer," & vbCrLf & vbCrLf & sMsg & vbCrLf & "Regards" .Display .Send End With Next c End Sub

بصراحة ليس لدي خبرة في مجال ايميلات الاوتولوك ولكن جربي هذا الكود واعلميني بما يحدث معك ليس لدي ايميل مربوط بالوتولوك حتى اجربه sub sendemail If MsgBox("Are you sure you would like to send this data?", vbYesNo) = vbNo Then Exit Sub Dim outlook As Object Dim newEmail As Object Dim xInspect As Object Dim pageEditor As Object Dim rng As Range Application.ScreenUpdating = False Set rng = Range("E2:E100") ActiveSheet.Sort.SortFields.Clear rng.Sort Key1:=rng.Cells(1), Order1:=xlAscending, Header:=xlNo Set outlook = CreateObject("Outlook.Application") Set newEmail = outlook.CreateItem(0) With newEmail .To = "Myemail.com" .CC = "" .BCC = "" .Subject = "" .Body = "Please see the report . Thanks" .Display Set xInspect = newEmail.GetInspector Set pageEditor = xInspect.WordEditor Sheet1.Range("a2:d100").Copy pageEditor.Application.Selection.Start = Len(.Body) pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText) .Display .Send Set pageEditor = Nothing Set xInspect = Nothing MsgBox "Your Orders Have Been Sent" End With End Sub

جرب هذا الماكرو البسيط Sub savepdf() ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="E:\pdf\" & Range("c4").Value End Sub حفظ بصيغة pdf تلقائيا.xlsm

اعتقد هذا قد ينفع معك ضع هذه الصيفة وليكن C2 =COUNTIF(A2:B4;"*محمد*")

تفضل اخي هذا ملف به جدول بسيط وكود بسيط Sub CopyTables() Worksheets(1).ListObjects("Table1").Range.Copy _ Destination:=Worksheets(2).Range("A1") End Sub copy table.xlsm

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

اخت ام حمزة جربي هذ الملف لا اعلم ان كان هذا ما تريدينه ولكن لاينطبق الا على كل مجلد يحتوي على ملف واحد والا لن يحدث الترتيب الذي تريده عليك مسح بيانات العموين ابتداء من الصف الثاني قومي بتسمية المجلدات كما كان موجود في العمود الاول وشغلي الماكرو OMHAMZAH.xlsm

اخي الكريم اليس هذا ما طلبته انا لا اعمل على التخمين كان وجب عليك توضيح ذلك من البداية

اعتقد هذا يفي بالغرض Sub Copy() Dim LastRow As Long LastRow = Sheets("Sheet1").Cells(Rows.Count, "b").End(xlUp).Row Sheets("Sheet1").Range("A" & LastRow - 9 & ":B" & LastRow).Copy Sheets("Sheet2").Range("h11") End Sub

يمكنك تجربة هذا الماكرو البسيط غير اسماء الشيتات بالانجليزي حتى لا يحدث خطا Sub copy() sheet1.Range("a16:b25").copy sheet2.Range("h11:i20") End Sub

قم بهذا التعديل Private Sub CommandButton2_Click() Application.Visible = True Dim sh As Worksheet With ThisWorkbook.Worksheets("micro") .Visible = xlSheetVisible .Activate End With For Each sh In ThisWorkbook.Worksheets(Array("RAW", "Date", "MICC", "REPORT", "LABLE")) sh.Visible = xlSheetVeryHidden Next sh UserForm1.Hide End Sub Private Sub CommandButton4_Click() Application.Visible = True Dim sh As Worksheet With ThisWorkbook.Worksheets("raw") .Visible = xlSheetVisible .Activate End With For Each sh In ThisWorkbook.Worksheets(Array("micro", "Date", "MICC", "REPORT", "LABLE")) sh.Visible = xlSheetVeryHidden Next sh UserForm1.Hide End Sub

كان وجب عليك توضيح هذا من البداية كما انك تكرر نفس رقم الزر commandbutton2 اعتقد ما تقصد به رقم 4 ملاحظة ليس في كل مرة ترد عليه تقوم بعمل اقتباس لمشاركتي هذا مضيعة للوقت الا في حالة الضرورة جرب هذا التعديل ليس لدي وقت للتجربة لكن اعتقد انه سيفي بالغرض Private Sub CommandButton2_Click() Application.Visible = True Sheets("micro").Activate Dim sh As Worksheet For Each sh In Worksheets(Array("RAW", "Date", "MICC", "REPORT", "LABLE")) sh.Visible = xlSheetVeryHidden Next sh UserForm1.hide End Sub Private Sub CommandButton4_Click() Application.Visible = True Sheets("raw").Activate Dim sh As Worksheet For Each sh In Worksheets(Array("MICRO", "Date", "MICC", "REPORT", "LABLE")) sh.Visible = xlSheetVeryHidden Next sh UserForm1.hide End Sub

يمكنك الاستعانة بهذه الاكواد ولكن يجب تنشيط الصفحة التي لاتريد اخفاءها Sub UNHideAllSheetsTABS() Dim WS As Worksheet For Each WS In ThisWorkbook.Worksheets If WS.Name <> ActiveSheet.Name Then WS.Visible = xlSheetVisible Next WS End Sub Sub hide() Dim WS As Worksheet For Each WS In ThisWorkbook.Worksheets If WS.Name <> ActiveSheet.Name Then WS.Visible = xlSheetVeryHidden Next WS End Sub TEST.xlsm

جرب هذا الكود لعله المطلوب اكتب في الخلايا e3,f3 الاسماء بعد كتابة التواريخ Sub bring_customers() Dim CustID As String: CustID = sheet2.[e3].Value Dim CustID1 As String: CustID1 = sheet2.[f3].Value Dim FromDt As Long: FromDt = sheet2.[d3].Value Dim ToDt As Long: ToDt = sheet2.[c3].Value Application.ScreenUpdating = False sheet2.[A5].CurrentRegion.Offset(1).Clear With sheet1.[A2].CurrentRegion .AutoFilter 3, CustID, xlOr, CustID1 .AutoFilter 2, ">=" & FromDt, xlAnd, "<=" & ToDt .Offset(1).EntireRow.Copy sheet2.Range("A" & Rows.Count).End(3)(2) .AutoFilter End With Application.ScreenUpdating = True End Sub Example.xlsm

اخي الكريم يجب الا تنزعج مما قاله اخي مهند مهما كان السؤال بسيط يجب الالتزام بقوانين المنتدى هو ادراج ملف هذا في مصلحة الاعضاء حتى يتسنى للاساتذة ان يتفاعلو ا معك على العموم جرب هذه المحاولات لعلها تفيدك 1- اذاكان الملف محمي قم بفك الحماية 2- اذا كان هناك ملفات اكسيل مفتوحة اغلقها 3- قم بحدف الملفات الموجودة في ملف temp داخل جهازك 4- نتيجة لتحديثات النظام قد يكون تم وضع قيود راجع اعدادات امان النظام 5- قم يتحديث الاوفيس لديك 6- الحل الاخير اعد تتبيث الاوفيس من جديد

اعتقد هذا المطلوب Private Sub Worksheet_PivotTableChangeSync(ByVal Target As PivotTable) Range("h2") = ActiveWorkbook.SlicerCaches(1).VisibleSlicerItems.Count End Sub count selected item in slicer .xlsm

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

يمكنك الاستفادة من هذا الملف على حسب ما فهمت =CHOOSE(MOD(ROW()-1;6)+1;"A";"B";"C";"D";"";"") numbering alphabet.xlsx

جرب هذا الكود يتم الفرز بناء على التاريخ Private Sub Worksheet_Change(ByVal Target As Range) Dim lastrow As Long lastrow = Cells(Rows.Count, 3).End(xlUp).Row Range("A2:c" & lastrow).Sort key1:=Range("c2:c" & lastrow), _ order1:=xlAscending, Header:=xlNo End Sub ترتيب تلفائى1.xlsm

على حسب معطياتك اعتقد هذا المطلوب بالكود لا يظهر التاريخ الا في حالة سداد قسط معين بناء على تاريخ اليوم ولن يتغير في الايام القادمة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Row > 6 Then If Target.Column = 5 Or Target.Column = 8 Or Target.Column = 11 Then If Target.Value = "سدد" Then Target.Offset(0, 1) = Date Else Target.Offset(0, 1) = "" End If End If End If End Sub حسابات (1).xlsb

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

هذا بالكود البرمجي لعله يساعدك تفضل Sub osama() Dim data, i As Long, fnd As Range With Range("B27:C" & Cells(Rows.Count, 3).End(xlUp).Row) data = .Value For i = LBound(data, 1) To UBound(data, 1) Set fnd = Range("C3:R21").Find(data(i, 2), , xlValues, xlWhole) If Not fnd Is Nothing Then data(i, 1) = Cells(fnd.Row, 2) Next i .Value = data End With End Sub جلب اسماء.xlsm

جرب هذا الكود لعله يفي بالغرض Sub Consolidation() Dim CurrentBook As Workbook Dim WS As Worksheet Set WS = ThisWorkbook.Sheets("sheet1") Dim IndvFiles As FileDialog Dim FileIdx As Long Dim i As Integer, x As Integer Set IndvFiles = Application.FileDialog(msoFileDialogOpen) With IndvFiles .AllowMultiSelect = True .Title = "Multi-select target data files:" .ButtonName = "" .Filters.Clear .Filters.Add ".xlsx files", "*.xlsx" .Show End With Application.DisplayAlerts = False Application.ScreenUpdating = False For FileIdx = 1 To IndvFiles.SelectedItems.Count Set CurrentBook = Workbooks.Open(IndvFiles.SelectedItems(FileIdx)) For Each Sheet In CurrentBook.Sheets Dim LRow1 As Long LRow1 = WS.Range("A" & WS.Rows.Count).End(xlUp).Row Dim LRow2 As Long LRow2 = CurrentBook.ActiveSheet.Range("A" & CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row Dim ImportRange As Range Set ImportRange = CurrentBook.ActiveSheet.Range("A2:d" & LRow2) ImportRange.Copy WS.Range("A" & LRow1 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Next CurrentBook.Close False Next FileIdx Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

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