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

نجوم المشاركات

  1. محمد هشام.

    محمد هشام.

    الخبراء


    • نقاط

      11

    • Posts

      1,588


  2. عبدالله بشير عبدالله
  3. ابو جودي

    ابو جودي

    أوفيسنا


    • نقاط

      1

    • Posts

      6,858


Popular Content

Showing content with the highest reputation on 15 ديس, 2024 in all areas

  1. يمكنك تعديل كود عرض الأعمدة بترتيب العناصر على الشكل التالي Private Sub ContrArr(tmp As Long) Dim controls As Variant, columns As Variant, i As Integer controls = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", "ComboBox4", _ "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5") columns = Array(2, 4, 5, 6, 7, 8, 9, 10, 11, 12) If Me.TextBox8.Text = "" Then ClearControls Else Me.TextBox8.Tag = tmp For i = LBound(controls) To UBound(controls) Me.controls(controls(i)).Text = WS.Cells(tmp, columns(i)).Value Next i tblUpdate tmp End If End Sub البحث والتنقل.rar
    2 points
  2. وعليكم السلام ورحمة الله وبركاته Private Sub Workbook_Open() On Error Resume Next ThisWorkbook.Sheets("الــــــــــــــــوارد ").ScrollArea = "A1:I753" End Sub "A1:I753" هذا النطاق يمكن تعديله وهو المسموح الكتابه به اذا اردت النطبيق على جداول اخرى انسخ ThisWorkbook.Sheets("الــــــــــــــــوارد ").ScrollArea = "A1:I753" والصقه بالكود وغير اسم الصفحة والنطاق سجل.xlsb
    2 points
  3. For tmp = 6 To Irow If IsNumeric(SrcWS.Cells(tmp, "A").Value) Then SrcWS.Cells(tmp, "A").ClearContents End If Next tmp مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsb
    2 points
  4. وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Const Clé As String = "1234" ' قم بتعديل الباسوورد بما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long lastRow = Cells(Rows.Count, "J").End(xlUp).Row ActiveSheet.Unprotect Clé If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing And Target.Columns.Count = 1 Then Application.EnableEvents = False Dim cell As Range For Each cell In Target If cell.Row >= 7 Then cell.Locked = Not IsEmpty(cell.Value) Next cell Application.EnableEvents = True End If ActiveSheet.Protect Clé, UserInterfaceOnly:=True End Sub '================================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lastRow As Long, choose As String: Static OnRng As Range lastRow = Cells(Rows.Count, "J").End(xlUp).Row If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing Then If Not IsEmpty(Target.Value) Then If Target.Locked Then choose = InputBox(": خلية التوقيع محمية الرجاء إدخال كلمة المرور", ":إنتــباه") If choose = Clé Then ActiveSheet.Unprotect Clé If Not OnRng Is Nothing Then OnRng.Locked = True Target.Locked = False Set OnRng = Target ActiveSheet.Protect Clé, UserInterfaceOnly:=True ElseIf choose <> "" Then MsgBox "كلمة المرور غير صحيحة", vbExclamation, "خطأ" End If Else Set OnRng = Target End If Else ActiveSheet.Unprotect Clé Target.Locked = False Set OnRng = Nothing ActiveSheet.Protect Clé, UserInterfaceOnly:=True End If End If End Sub شيت حوافز تجريبى V2.xlsb
    2 points
  5. اداة البحث هذه قمت بمحاولة تجميع الافكار فيها بعناية وبترتيبها لمحاولة الوصول الى اقصى درجات الكفائة والمرونة الممكنة اولا : تعرية وتطهير النص والتحكم فى ذلك حسب الحاجة كما سبق التنويه عن هذه الجزئية فى هذا الموضوع ثانيا : التحكم فى اعداد مصادر البيانت :- (مصدر البيانات"جدول /استعلام" - الحقولالبحث المخصصة - امكانية اضافة حقل او اكثر يعتمد على تطهير النصوص ثالثا : آلية البحث بحيث يمكن البحث من خلال ( الكلمة تبدأ بـ - تنتهى بـ - يتضمن الكلمة فى امكان - او متطابق تماما او لو عدد الكلمات كثير يمكن كتابة جزء من كل كلمة فى نفس السجل ولا يشترط الترتيب ) مثال : نريد البحث فى السجل قيمة هذا السجل : 26675 فوزي عبد الحميد ابو الفتوح محمد سعده لو تم اختيار من إعدادت البحث : يحتوى على اكثر من كلمة او جزء من كلمه يفصل بينهم مسافة من إعدادت البحث ثم كتبنا فى مربع البحث : عب فت سع 66 نحصل على النتيجة اثناء كتابة الكود تم عمل جدول باسم : tblSearchSettings بحيث يتم حفظ الاعدادت الخاصة بعملية البحث والفرز والتصفية تم وضع القيم الافتراضية لاجراء عمليات البحث والفرز والتصفية المتعددة على اكمل وجهة فى حالة حذف الجدول الخاص باعدادت البحث كما انها تمثل مرونة قصوى لكل مستخدم على حدى فى حالة استخدام شبكة محلية يستطيع كل مستخدم الاحتفاظ بالاعدادت التى تناسبه دون التأثير على الاخرين اخيرا المرفق واترككم مع التجربة Search Utility V 3.0.2.accdb
    1 point
  6. وعليكم السلام ورحمة الله تعالى وبركاته ربما هدا ما تقصده ادا كنت قد فهمت طلبك بشكل صحيح يمكنك حدف جميع الأكواد السابقة فهدا سيوفي بالغرض بعد إظافة عنصر Label جديد بإسم Label15 لإظهار عدد السجلات كما في الصورة المرفقة Public WS As Worksheet Private Sub UserForm_Initialize() Set WS = Sheets("تسجيل البيانات") End Sub Private Sub Navigation(r As Integer) Dim NInvoice As String, tmp As Long, Col As Long NInvoice = Trim(TextBox8.Text) If NInvoice = "" Then MsgBox "يرجى إدخال رقم الفاتورة", vbExclamation Exit Sub End If tmp = TextBox8.Tag Col = FndRow(NInvoice, tmp, r) If Col = 0 Then MsgBox TextBox8.Value & " : " & "لا يوجد سجلات " & IIf(r = 1, "لاحقة", "سابقة") & _ " بنفس رقم الفاتورة", vbExclamation Else ContrArr Col End If End Sub Private Function FndRow(facture As String, c As Long, r As Integer) As Long Dim tmp As Long, lastRow As Long lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If r = 1 Then For tmp = c + 1 To lastRow If WS.Cells(tmp, 1).Value = facture Then FndRow = tmp Exit Function End If Next tmp Else For tmp = c - 1 To 2 Step -1 If WS.Cells(tmp, 1).Value = facture Then FndRow = tmp Exit Function End If Next tmp End If FndRow = 0 End Function Private Sub ContrArr(tmp As Long) Dim n As Variant n = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", "ComboBox4", _ "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5") If Me.TextBox8.Text = "" Then ClearControls Else Me.TextBox8.Tag = tmp For i = LBound(n) To UBound(n) Me.Controls(n(i)).Text = WS.Cells(tmp, i + 2).Value Next i tblUpdate tmp End If End Sub Private Sub SpinButton2_SpinDown() Navigation 1 End Sub Private Sub SpinButton2_SpinUp() Navigation -1 End Sub Private Sub résultats(facture As String) Dim Irow As Long Irow = ColRecherche(facture) If Irow = 0 Then MsgBox TextBox8.Value & " : " & "لا يوجد بيانات مطابقة لرقم الفاتورة", vbExclamation, "إنتـــباه" Me.TextBox8.Text = "" Label15.Caption = "السجل 1 من 1" Label15.Visible = False Else ContrArr Irow End If End Sub Private Function ColRecherche(facture As String) As Long Dim ColA As Range, cell As Range Set ColA = WS.Range("A2:A" & WS.Cells(WS.Rows.Count, 1).End(xlUp).Row) For Each cell In ColA If cell.Value = facture Then ColRecherche = cell.Row Exit Function End If Next cell ColRecherche = 0 End Function Private Sub ClearControls() Dim n As Variant n = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", _ "ComboBox4", "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5") For i = LBound(n) To UBound(n) Me.Controls(n(i)).Text = "" Next i Me.TextBox8.Tag = "" Label15.Caption = "السجل 1 من 1" Label15.Visible = False End Sub Private Sub TextBox8_Change() If Me.TextBox8.Text = "" Then ClearControls Label15.Visible = False Exit Sub End If If Not IsNumeric(Me.TextBox8.Text) Then MsgBox "الرجاء إدخال قيمة رقمية فقط", vbExclamation Me.TextBox8.Text = "" ClearControls Exit Sub End If résultats Trim(TextBox8.Text) End Sub Private Sub tblUpdate(tblRow As Long) Dim facture As String, tblCount As Long, tmp As Long, lastRow As Long, tblMatch As Long facture = Trim(TextBox8.Text) lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row tblMatch = 0: tblCount = 0 For tmp = 2 To lastRow If WS.Cells(tmp, 1).Value = facture Then tblCount = tblCount + 1 If tmp = tblRow Then tblMatch = tblCount End If End If Next tmp Label15.Caption = "السجل " & tblMatch & " من " & tblCount Label15.Visible = True End Sub لقد قمت برفع ملفين: الأول بدون إظهار عدد السجلات والثاني يقوم بإظهارها يمكنك اختيار ما يناسبك بالتوفيق........... البحث والتنقل.rar
    1 point
  7. If Not Intersect(Target, Me.Range("I:L")) Is Nothing Then UnitsArr = Array("فدان", "قيراط", "سهم", "م²") With srcWS lastRow = .Columns("I:L").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastRow < 10 Then Exit Sub ColArr = .Range("I10:L" & lastRow).Value ReDim tmp(1 To lastRow - 9, 1 To 1) For i = 1 To UBound(ColArr, 1) tbl = "" For j = 4 To 1 Step -1 If IsNumeric(ColArr(i, j)) And ColArr(i, j) > 0 Then tbl = tbl & IIf(tbl <> "", " و ", "") & ColArr(i, j) & " " & UnitsArr(4 - j) End If Next j tmp(i, 1) = tbl Next i مساحة2.xlsb
    1 point
  8. وعليكم السلام ورحمة الله تعالى وبركاته بإستخدام الأكواد يمكنك تجربة هدا Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ExitApp Application.EnableEvents = False Dim tmp() As Variant, ColArr As Variant, lastRow As Long, _ UnitsArr As Variant, i As Long, j As Integer, tbl As String Dim srcWS As Worksheet: Set srcWS = Me If Not Intersect(Target, Me.Range("I:L")) Is Nothing Then UnitsArr = Array("م²", "سهم", "قيراط", "فدان") With srcWS lastRow = .Columns("I:L").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastRow < 10 Then Exit Sub ColArr = .Range("I10:L" & lastRow).Value ReDim tmp(1 To lastRow - 9, 1 To 1) For i = 1 To UBound(ColArr, 1) tbl = "" For j = 1 To 4 If IsNumeric(ColArr(i, j)) And ColArr(i, j) > 0 Then tbl = tbl & IIf(tbl <> "", " و ", "") & ColArr(i, j) & " " & UnitsArr(j - 1) End If Next j tmp(i, 1) = tbl Next i With .Range("M10:M" & lastRow) .Value = tmp .ReadingOrder = xlRTL End With End With End If ExitApp: Application.EnableEvents = True End Sub مساحة.xlsb
    1 point
  9. بما أنك لم تجب عن سؤالي إليك طريقة أخرى ستقوم بإظافة عنصر جديد بإسم Line لإستخراج رقم صف المحدد عند الإختيار من عناصر الكومبوبوكس وإعتمادا عليه سنقوم بتعديل وحدف الصفوف Private Sub SearchData() Dim fnd As Range Dim ColA As String, ColB As String, ColC As String Dim criteria As Range, found As Boolean Dim rowNum As Long ColA = Me.ComboBox1.Value ColB = Me.ComboBox2.Value ColC = Me.ComboBox3.Value If Len(ColA) = 0 Then Exit Sub Set criteria = WS.Range("A4:C" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) found = False For Each fnd In criteria.Rows If fnd.Cells(1, 1).Value = ColA And _ (ColB = "" Or Format(fnd.Cells(1, 2).Value, "dd-mmm") = ColB) And _ (ColC = "" Or fnd.Cells(1, 3).Value = ColC) Then For i = 1 To 62 Me.Controls("TextBox" & i).Value = fnd.Cells(1, i).Value Next i rowNum = fnd.Row found = True Exit For End If Next fnd If Not found Then ClearTextBoxes Me.Line.Value = "" Else Me.Line.Value = rowNum End If End Sub Private Sub CommandButton2_Click() Dim r As Integer, n As Variant Dim i As Integer, X As Integer Dim rowNum As Long, fnd As Range If IsNumeric(Me.Line.Value) Then rowNum = CLng(Me.Line.Value) Else MsgBox " يرجى تحديدالبيانات المرغوب تعديلها", vbExclamation Exit Sub End If If rowNum < 5 Then: Exit Sub If SaisieText(1, 2) Then Exit Sub r = MsgBox("تعديل البيانات؟", vbYesNo, "تأكيـــد") If r <> vbYes Then Exit Sub Application.ScreenUpdating = False Set fnd = WS.Cells(rowNum, 1) For i = 1 To 62 On Error Resume Next n = Me.Controls("TextBox" & i).Value On Error GoTo 0 If IsDate(n) Then fnd.Offset(0, i - 1).Value = CDate(n) Else fnd.Offset(0, i - 1).Value = n End If Next i Call UpdateNum(WS) Clear_TextBox UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم التعديل بنجاح", vbInformation End Sub Private Function SaisieText(startIdx As Integer, endIdx As Integer) As Boolean Dim i As Integer, X As Integer Dim arr() As String, TexArr As String For i = startIdx To endIdx If Me.Controls("TextBox" & i).Value = "" Then TexArr = Me.Controls("cnt" & i).Caption ReDim Preserve arr(X) arr(X) = TexArr X = X + 1 End If Next i If X > 0 Then MsgBox ": يرجى التحقق من " & Chr(10) & Join(arr, " - "), vbInformation SaisieText = True Else SaisieText = False End If End Function ترحيل مع كمبوبوكس البحث بحقلين V3.xlsm
    1 point
  10. السلام عليكم ورحمة الله تعالى وبركاته بعد ادن الاستاد @عبدالله بشير عبدالله اليك حل اخر ربما يناسبك هدا الكود لفلترة البيانات بين التواريخ ونسخها لورقة مخفية على نفس المصنف باسم printing Sub FilterByDate() Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim f As Worksheet: Set f = printing Dim MinDate As Date, MaxDate As Date, lr As Long Dim a As Range, r As Long MinDate = desWS.[d2]: MaxDate = desWS.[f2] Application.ScreenUpdating = False If MinDate > MaxDate Then: Exit Sub If Len(desWS.[f2]) > 0 And IsDate(desWS.[d2]) Then If WS.AutoFilterMode Then WS.AutoFilterMode = False With WS.Range("A7:K7") .AutoFilter 3, ">=" & CLng(MinDate), 1, "<=" & CLng(MaxDate) lr = WS.Columns("A:K").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set rng = WS.Range("A" & lr & ":k" & lr).SpecialCells(xlCellTypeVisible) If WorksheetFunction.Subtotal(3, WS.Columns(3)) > 1 Then desWS.Range("A5:K" & Rows.Count).Clear With rng Cpt = Split("A,B,C,D,E,F,G,H,I,J,k", ",") Col = Split("A,B,C,D,E,F,G,H,I,J,k", ",") For i = LBound(Cpt) To UBound(Cpt) WS.Range(Cpt(i) & "8:" & Cpt(i) & lr).Copy desWS.Range(Col(i) & "5") Next i End With lige = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Cpt1 = "=IF(c5="""","""",IF(c5=""Name"",""Count"",N(b4)+1))" Cpt2 = "=IF(ISBLANK(b5),"""",SUBTOTAL(3,B$5:B5))" With desWS .Range("B5:B" & lige).Formula = Cpt1: .Range("A5:A" & lige).Formula = Cpt2 .Range("A5:B" & lige).Value = .Range("A5:B" & lige).Value End With End If .AutoFilter End With f.Range("A2:K" & f.Rows.Count).Clear Set a = desWS.Range("A4", desWS.Range("A" & desWS.Rows.Count).End(xlUp)) For r = 1 To 11 Set a = Union(a, Intersect(a.EntireRow, Columns(r))) Next r a.Copy Destination:=f.Range("a2") End If Application.ScreenUpdating = True End Sub لحفظ الملف بصيغة PDF Sub Save_folder_PDF() Dim sFile As String, sPath As String, fPath As String Dim sMsg As String Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim f As Worksheet: Set f = printing sFile = "تقرير النشاط" folderName = "ملفات PDF" Application.ScreenUpdating = False Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, f.Name) If Msg <> vbYes Then Exit Sub f.Visible = xlSheetVisible With ActiveWorkbook sPath = .path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then End If MkDir sPath f.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 f.ExportAsFixedFormat Type:=xlTypePDF, _ FileName:=sPath & Application.PathSeparator & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False f.Visible = xlSheetVeryHidden End With sMsg = "PDF" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] Application.ScreenUpdating = True End Sub لحفظ التقرير في ملف مستقل Sub Save_folder_Excel() Dim WS As Worksheet: Set WS = printing Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim path As String, folderName As String, sMsg As String Dim newWb As Workbook, Fname As String path = ThisWorkbook.path & "\" On Error Resume Next Msg = MsgBox("؟" & " " & "Excel " & ":" & " تصدير التقرير بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False WS.Visible = xlSheetVisible folderName = "ملفات Excel" MkDir path & folderName Fname = folderName & "\" & WS.Name WS.Copy Set newWb = ActiveWorkbook newWb.SaveAs FileName:=path & Fname & ".xlsx", FileFormat:=51 newWb.Close WS.Visible = xlSheetVeryHidden .DisplayAlerts = True .ScreenUpdating = True End With On Error GoTo 0 sMsg = "Excel" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] End Sub فلترة وحفظ PDF +EXCEL.xlsm
    1 point
  11. اتمنى ان يكون طلبك في هذا الملف يتم تكوين مجلدين احدهما باسم باسم تقرير اكسل والاخر تقرير PDF في نفس مجلد الملف الرئيسي الكودين لاستاذنا المبدع محمد هشام اكسل وPDF.xlsb
    1 point
×
×
  • اضف...

Important Information