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

lionheart

الخبراء
  • Posts

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

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

  • Days Won

    27

Community Answers

  1. lionheart's post in تحويل الاعداد من الحالة الافقية الى تسلسل راسي was marked as the answer   
    Try
    Sub Test() Dim ws As Worksheet, m As Long, i As Long, ii As Long Application.ScreenUpdating = False Set ws = ActiveSheet: m = 2 With ws .Columns("K:M").Clear .Columns("M").ColumnWidth = 11 With .Range("K1").Resize(, 3) .Value = Array("Group", "Number", "Work Date") .Interior.Color = RGB(146, 205, 220) .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With For i = 2 To 6 If .Cells(i, 2).Value < .Cells(i, 3).Value And IsNumeric(.Cells(i, 2).Value) And IsNumeric(.Cells(i, 2).Value) Then For ii = .Cells(i, 2).Value To .Cells(i, 3).Value .Cells(m, "K").Resize(, 3).Value = Array(.Cells(i, 1).Value, ii, .Cells(i, 4).Value) m = m + 1 Next ii End If Next i End With Application.ScreenUpdating = True End Sub  
  2. lionheart's post in تكويد المواد was marked as the answer   
    Here's a version that merges cells although I see not practical and not useful later
    Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, n As Long, i As Long, c As Long Set ws = ThisWorkbook.Worksheets("1") Set sh = ThisWorkbook.Worksheets("2") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then Exit Sub m = 5: n = m Application.ScreenUpdating = False Application.DisplayAlerts = False With sh.Rows("5:" & Rows.Count) .ClearContents: .Borders.Value = 0: .UnMerge: .RowHeight = 20.25 End With For r = 6 To lr If ws.Cells(r, 4).Value > 0 Then For i = 1 To ws.Cells(r, 4).Value sh.Cells(m, 1).Value = ws.Cells(r, 2).Value sh.Cells(m, 2).Value = ws.Cells(r, 3).Value sh.Cells(m, 3).Value = ws.Cells(r, 4).Value sh.Cells(m, 4).Value = ws.Range("D3").Value & ws.Cells(r, 1).Value & ws.Cells(r, 2).Value & i m = m + 1 Next i For c = 1 To 3 With sh.Range(sh.Cells(n, c), sh.Cells(m - 1, c)) .Merge: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Next c If lr = r Then Exit For sh.Cells(m, 1).Resize(, 4).Interior.Color = vbMagenta m = m + 1 n = m End If Next r sh.Range("A5:F" & m - 1).Borders.Value = 1 Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub  
  3. lionheart's post in مطلوب كود إخفاء أسطر بشرط موجود فى خلية was marked as the answer   
    The error is because you have protected your worksheets so I think you encountered the error. To fix the problem just unprotect the worksheet before working on it and at the end to protect it again
    Sub HideRowsBasedOnCondition() Dim conditionValue, ws As Worksheet, conditionCell As Range, rowRange As Range For Each ws In ThisWorkbook.Sheets Set conditionCell = ws.Range("V1") conditionValue = conditionCell.Value ws.Unprotect ws.Rows.Hidden = False If conditionValue = 28 Then Set rowRange = ws.Rows("1363:1387") rowRange.Hidden = True ElseIf conditionValue = 29 Then Set rowRange = ws.Rows("1361:1362") rowRange.Hidden = True End If ws.Protect Next ws End Sub I just added two lines
    ws.Unprotect And
    ws.Protect  
  4. lionheart's post in محتاج كود ترحيل تقيم الطلاب من جدول الى جدول اخر was marked as the answer   
    Try this code
    Sub Test() Dim ws As Worksheet, r As Long, lr As Long, i As Long, j As Long, m As Long Application.ScreenUpdating = False Set ws = Sheet1 ReDim a(1 To 1000, 1 To 17) With ws lr = .Cells(Rows.Count, "B").End(xlUp).Row For r = 10 To lr If Application.WorksheetFunction.CountBlank(.Range("E" & r).Resize(, 11)) <> 11 Then i = i + 1 For j = 2 To 18 a(i, j - 1) = .Cells(r, j).Value Next j End If Next r If i > 0 Then m = .Cells(Rows.Count, "AM").End(xlUp).Row + 1 m = IIf(m = 5, 9, m) .Range("AM" & m).Resize(i, UBound(a, 2)).Value = a Application.Goto .Range("AM" & m), True End If End With Application.ScreenUpdating = True MsgBox "Done", 64 End Sub  
  5. lionheart's post in كيفية زياد الارقام من الى was marked as the answer   
    In cell D1 type the number 666 then in cell D4 put the formula
    ="Shatbeyya "&($D$1+5*(ROW()-4))&"-"&($D$1+4+5*(ROW()-4))  
  6. lionheart's post in النص داخل التكست بوكس يحتوي علي المطلبوب was marked as the answer   
    Try this code
    Private Sub UserForm_Initialize() With Me.TextBox1 .Text = "Hello World" .Enabled = False End With End Sub Private Sub TextBox2_Change() Dim s As String, i As Long s = Me.TextBox2.Value For i = 1 To Len(s) If InStr(1, Me.TextBox1.Value, Mid(s, i, 1)) > 0 Then MsgBox Mid(s, i, 1) & " Is Found In TextBox1" s = Replace(s, Mid(s, i, 1), vbNullString) Me.TextBox2.Value = s Exit For End If Next i End Sub  
  7. lionheart's post in المساعده بإصلاح الكود المتمثل عمله بالفرز والتصفية was marked as the answer   
    Try
    Sub Test() Dim lr As Long With ActiveSheet lr = .Cells(Rows.Count, 1).End(xlUp).Row With .Sort .SortFields.Clear .SortFields.Add Key:=Range("F3"), Order:=xlAscending .SortFields.Add Key:=Range("G3"), Order:=xlDescending .SortFields.Add Key:=Range("H3"), Order:=xlAscending .SetRange ActiveSheet.Range("A3:H" & lr) .Header = xlYes .Apply End With End With End Sub  
  8. lionheart's post in طلب كود لعداد تنازلي في هذه الخلية was marked as the answer   
    In ThisWorkbook Module
    Private Sub Workbook_Open() Application.OnKey "{F9}", "TestMacro" End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.OnKey "{F9}" End Sub  
    In Standard Module
    Sub TestMacro() Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("Qution") ws.Range("G17").Value = Empty: ws.Range("D17").Value = Empty With ws.Range("D17") .Formula = "=RANDBETWEEN(data1!A1,data1!A30)" .Value = .Value End With With Application .ScreenUpdating = True .EnableEvents = False .Calculation = xlCalculationManual .Wait Now + TimeValue("00:00:05") ws.Range("G17").Formula = "=LOOKUP(D17,data1!A1:A730,data1!F1:F30)" .Calculate .Calculation = xlCalculationAutomatic .EnableEvents = True End With End Sub  
  9. lionheart's post in كود تصميم زر اخفاء واظهار صفوف محددة was marked as the answer   
    Try this code
    Sub ToggleButton_ON_OFF() Const ONKEY As String = "On", OFFKEY As String = "Off" Dim ws As Worksheet, shOnOff As Shape, shToggle As Shape, shRadio As Shape, s As String Set ws = ActiveSheet With ws Set shOnOff = .Shapes("txtboxOnOff") Set shToggle = .Shapes("ToggleButton1") Set shRadio = .Shapes("radioButton") End With With shOnOff s = .TextFrame.Characters.Text .TextFrame.Characters.Text = IIf(s = ONKEY, OFFKEY, ONKEY) ws.Rows("12").Hidden = (s = OFFKEY) .TextFrame.HorizontalAlignment = IIf(s = ONKEY, xlHAlignLeft, xlHAlignRight) shToggle.Fill.ForeColor.RGB = IIf(s = ONKEY, RGB(232, 27, 34), RGB(117, 199, 1)) shRadio.Left = shToggle.Left + IIf(s = ONKEY, shToggle.Width - shRadio.Width - 5, 5) End With End Sub  
  10. lionheart's post in تصفية لكل صف was marked as the answer   
    Use this code
    Sub DropDownSelection() Dim v, x, ws As Worksheet, myDrop As DropDown Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("1") Set myDrop = ActiveSheet.DropDowns("myDropDown") v = myDrop.List(myDrop.Value) x = Application.Match(v, ws.Columns(3), 0) If Not IsError(x) Then With ActiveSheet .Range("C9").Value = ws.Cells(x, 3).Value .Range("J9").Value = ws.Cells(x, 4).Value 'complete by yourself End With End If Application.ScreenUpdating = True End Sub  
    Assign macro to the drop down by right-click on the drop down and select Assign Macro and select the macro name [DropDownSelection]
  11. lionheart's post in ترحيل الطلبة الراسبة بناء علي مادة الرسوب باستخدام list was marked as the answer   
    I don't like attaching files
    But I see there is a huge mess
     
    Click Down arrow first then use Up arrow
    File.xlsb
  12. lionheart's post in كود لون خط خلية يكون ابيض بشرط was marked as the answer   
    Steps to solve the problem using conditional formatting
    First: Select Range A1:A7
     
    Second: From Home Tab Select Conditional Formatting  & New Rule

     
    Third: Select Rule [Use a formula to determine which cells to format] - Type Formule [=B1=0] - Click [Format]

     
    Fourth: Select Tab >> Color DropDown >> Select [White, Backgrounds 1] >> Click [OK]

     
    Finally Click OK To Close [New FOrmatting Rule] Window

  13. lionheart's post in رسم دوائر was marked as the answer   
    Try this code
    Sub DrawCircles() Const SROW As Long = 7, EROW As Long = 11, SCOL As Long = 2, ECOL As Long = 10 Dim ws As Worksheet, sColName As String, i As Long, j As Long, n As Long, rd As Double Application.ScreenUpdating = False Call RemoveCircles Set ws = ActiveSheet For i = SROW To EROW With ws n = .Range("K" & i).Value For j = ECOL To SCOL Step -1 If .Range(.Cells(i, j).Address).Value <> Empty And n > 0 Then rd = 0.5 * Application.Min(.Cells(i, j).Height, .Cells(i, j).Width) sColName = Split(.Cells(1, j).Address, "$")(1) With ActiveSheet.Shapes.AddShape(msoShapeOval, Range(sColName & i).Left + 0.5 * (.Range(sColName & i).Width - 2 * rd), .Range(sColName & i).Top + 0.5 * (.Range(sColName & i).Height - 2 * rd), 2 * rd, 2 * rd) .Line.Weight = 1.5 .Line.ForeColor.RGB = RGB(0, 0, 255) .Fill.Visible = msoFalse End With n = n - 1 End If If n = 0 Then Exit For Next j End With Next i Application.ScreenUpdating = True End Sub Private Sub RemoveCircles() Dim shp As shape For Each shp In ActiveSheet.Shapes If shp.AutoShapeType = msoShapeOval Then shp.Delete Next shp End Sub  
    Const SROW As Long = 7, EROW As Long = 11, SCOL As Long = 2, ECOL As Long = 10 In this line you can specify the start row SROW & end row EROW & start column SCOL & end column ECOL
  14. lionheart's post in عند عمل حماية واختار رقم من القائمة المنسدلة لا تتغير الصورة حاولت تطبيق الكود على الملف التالى ولم افلح من الورقة الاولى was marked as the answer   
    When protecting the worksheet, you have to follow these steps
    Review Tab >> Click on Protect Sheet
    Check the option Edit Objects
    Enter your password if you desire and you can leave it empty
  15. lionheart's post in كود ترحيل was marked as the answer   
    Here's the code and please try to learn from the solutions as it is a bad attitude to wait the help all the time from other people
    Sub Test() Dim a, e, sh As Worksheet, f As Boolean, lr As Long, r As Long Application.ScreenUpdating = False Set sh = ThisWorkbook.Worksheets("Saad") f = True: sh.Cells.ClearContents For Each e In Array("Sheet1", "Sheet2", "Sheet3") With ThisWorkbook.Worksheets(e) lr = .Cells(Rows.Count, "M").End(xlUp).Row a = .Range("K5:X" & lr).Value If f Then r = 5: f = False Else r = sh.Cells(Rows.Count, "C").End(xlUp).Row + 1 sh.Cells(r, "C").Resize(UBound(a, 1), UBound(a, 2)).Value = a End With Next e Application.ScreenUpdating = True End Sub  
  16. lionheart's post in توزيع رقم was marked as the answer   
    Here's a modified udf to be compatible with older versions of excel
    Function DistributeNumber(ByVal num As Long, ByVal chunks As Long, ByVal iIndex As Long) Dim i As Long ReDim b(chunks - 1) For i = 0 To chunks - 1 If i = chunks - 1 Then b(i) = num Else b(i) = WorksheetFunction.RoundUp(num / (chunks - i), 0) num = num - b(i) End If Next i On Error Resume Next DistributeNumber = b(iIndex - 1) If Err.Number <> 0 Then DistributeNumber = vbNullString: Err.Clear On Error GoTo 0 End Function  
    you can use the udf as formula (but you will have to drag the formula)
    Say the number is K1 so the formula in cell K2 should be
    =DistributeNumber(K$1,5,ROW(A1)) Drag the formula down to get the results

  17. lionheart's post in تنسيق رقم داخل دائرة was marked as the answer   
    Try this
    Option Explicit Sub Add_Circles() Dim ws As Worksheet, myRng As Range, c As Range, v As Shape, col As Long Application.ScreenUpdating = False Set ws = ActiveSheet Set myRng = ws.Range("F3:N13") myRng.RowHeight = 35: myRng.ColumnWidth = 10 Call Remove_Circles For Each c In myRng.Cells col = c.Column If c.Value < ws.Cells(2, col) Or c.Value = Chr(219) Then Set v = ws.Shapes.AddShape(msoShapeOval, c.Left + 15, c.Top + 2, 30, 30) With v With .Fill .Visible = msoTrue .ForeColor.RGB = RGB(166, 166, 166) End With With .TextFrame2 .TextRange.ParagraphFormat.Alignment = msoAlignCenter With .TextRange.Font .Fill.ForeColor.RGB = RGB(0, 0, 0) .Size = c.Font.Size .Bold = c.Font.Bold .Name = c.Font.Name End With .WordWrap = msoFalse End With With .TextFrame .Characters.Text = c.Value .MarginRight = 4 .MarginTop = 2 .MarginLeft = 4 .MarginBottom = 2 End With End With End If Next c Application.ScreenUpdating = True End Sub Sub Remove_Circles() Dim shp As Shape For Each shp In ActiveSheet.Shapes If shp.AutoShapeType = msoShapeOval Then shp.Delete Next shp End Sub  
  18. lionheart's post in مطلوب كود أبجدة وترتيب بشروط معينة was marked as the answer   
    The file is not perfect file as it has a lot of formulas that make the file slow. Generally follow the steps accurately to solve the problem of sort
     
    First select the shape that has the caption GIRLS and rename the shape from the Name Box to shpGirls

     
    Do the same step with the shape of BOYS and rename it to shpBoys
     
    Insert new module and paste the code
    Sub Sort_By_Boys_Girls() Dim shp As Shape, lr As Long, n As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set shp = ActiveSheet.Shapes(Application.Caller) If shp.Name = "shpGirls" Then n = 1 Else n = 2 With ActiveSheet lr = .Cells(Rows.Count, "D").End(xlUp).Row With .Sort .SortFields.Clear .SortFields.Add Key:=Range("F9"), Order:=xlAscending .SortFields.Add Key:=Range("I9"), Order:=n .SortFields.Add Key:=Range("D9"), Order:=xlAscending .SetRange ActiveSheet.Range("D9:AH" & lr) .Header = xlNo .Apply End With End With Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub  
     Finally assign the macro named [Sort_By_Boys_Girls] to both the shapes
     

  19. lionheart's post in البحث عن إسم طالب was marked as the answer   
    The topic must be CLOSED as you did not respond properly to Mohamed Hicham in a good way
    Generally, I will share my idea but I will not extend my reply if you have more questions
     
    First create a userform with TextBox1 & ListBox1 controls
    Second paste the following code on userform module
    Option Explicit Private arrData, ws As Worksheet Private Sub UserForm_Initialize() Dim lr As Long Set ws = ThisWorkbook.Worksheets(1) lr = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row arrData = ws.Range("C3:C" & lr).Value Me.ListBox1.List = Application.Transpose(arrData) End Sub Private Sub TextBox1_Change() Dim txt As String, i As Long Me.ListBox1.Clear If Len(Me.TextBox1.Value) = 0 Then Me.ListBox1.List = Application.Transpose(arrData): Exit Sub txt = Me.TextBox1.Value For i = LBound(arrData) To UBound(arrData) If InStr(LCase(arrData(i, 1)), LCase(txt)) > 0 Then Me.ListBox1.AddItem arrData(i, 1) End If Next i End Sub Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim x x = Application.Match(ListBox1.Value, ws.Columns(3), 0) With ws.Range("H3").Resize(, 4) .ClearContents If Not IsError(x) Then .Value = ws.Range("B" & x).Resize(, 4).Value Unload Me End If End With End Sub  
    Now right-click the worksheet name and select [View Code] and paste the following code
    Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Address = "$H$3" Then Cancel = True UserForm1.Show End If End Sub  
    The code usage
    --------------------
    Double click on cell H3 and the form will be shown then type some letters of the name you need to search and finally double click the name on the listbox to get the results in the range H3 to K3
    Regards
     
  20. lionheart's post in حساب عدد الفواتير بين تاريخين بالاعتماد على تاريخ فاتورة العميل was marked as the answer   
    Try this formula
    =IF(C5="","",IF(AND(C5>$A$2,C5<=$B$2)=FALSE,"Not Calculated",IF(COUNTIF($A$5:$A5,A5)>3,"Not Rounded","Calculated")))  
  21. lionheart's post in ترحيل بيانات الي شيت orders was marked as the answer   
    Try
    Sub Test() Dim ws As Worksheet, sh As Worksheet, tbl As ListObject, lr As Long, i As Long Application.ScreenUpdating = False With ThisWorkbook Set ws = .Worksheets("Items"): Set sh = .Worksheets("Orders") End With Set tbl = sh.ListObjects(1) lr = tbl.Range.Rows.Count + tbl.Range.Row - 1 Do While sh.Cells(lr, "C").Value = Empty lr = lr - 1 Loop lr = lr + 1 Dim a(1 To 16), e For Each e In Split("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,J18,F20", ",") i = i + 1 a(i) = ws.Range(e).Value Next e sh.Range("C" & lr).Resize(, 16).Value = a Application.ScreenUpdating = True MsgBox "Done", 64 End Sub  
  22. lionheart's post in مطلوب عدم تنفيذ الكود اذا كانت الخلية فارغة was marked as the answer   
    Very bad approach to use macro recorder
    Generally try the code that do the same steps
    Sub Test() Dim rng As Range, lr As Long With ActiveSheet If .Range("A10").Value = Empty Then MsgBox "Enter Number", vbExclamation: Exit Sub Application.ScreenUpdating = False Set rng = .Range("A10").Resize(, 9) lr = .Cells(Rows.Count, "Z").End(xlUp).Row + 1 .Range("Z" & lr).Resize(, 9).Value = rng.Value rng.SpecialCells(xlCellTypeConstants).ClearContents Application.ScreenUpdating = True End With End Sub  
  23. lionheart's post in عداد - لجلب بيانات - تلقائية was marked as the answer   
    Hello. Try the following code that is not exactly as you need but give it a try
    All the bills will be exported to only one pdf to Desktop instead of creating a pdf for each bill
    Sub Export_All_Bills_To_One_PDF() Dim bill, wb As Workbook, wsData As Worksheet, wsBill As Worksheet, wsCounter As Worksheet, shp As Shape, lr As Long, ls As Long, r As Long, m As Long, n As Long Application.ScreenUpdating = False With ThisWorkbook Set wsData = .Worksheets(1): Set wsBill = .Worksheets(2): Set wsCounter = .Worksheets(3) End With lr = wsCounter.Cells(Rows.Count, "A").End(xlUp).Row ls = wsData.Cells(Rows.Count, "B").End(xlUp).Row Set wb = Workbooks.Add(xlWBATWorksheet) For r = 2 To lr wsBill.Range("D1").Value = wsCounter.Cells(r, 1).Value bill = wsBill.Range("A2").Value wsBill.Range("A6:B30").ClearContents: n = 6 For m = 3 To ls If wsData.Cells(m, "B").Value = bill Then wsBill.Range("A" & n).Resize(, 2).Value = wsData.Range("C" & m).Resize(, 2).Value n = n + 1 End If Next m wsBill.Copy After:=wb.Worksheets(wb.Worksheets.Count) With ActiveSheet .Range("A2").Value = .Range("A2").Value .Range("D1").ClearContents For Each shp In .Shapes shp.Delete Next shp End With Next r Application.DisplayAlerts = False wb.Worksheets(1).Delete Application.DisplayAlerts = True wb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Environ("USERPROFILE") & "\Desktop\" & "All_Bills.pdf", OpenAfterPublish:=True wb.Close SaveChanges:=False Application.ScreenUpdating = True End Sub  
  24. lionheart's post in ترحيل مشروط was marked as the answer   
    Try
    Sub Test() Dim a, e, ws As Worksheet, sh As Worksheet, i As Long Set ws = ThisWorkbook.Worksheets(1): Set sh = ThisWorkbook.Worksheets(2) a = ws.Range("B11:J" & ws.Cells(Rows.Count, "B").End(xlUp).Row).Value e = sh.Range("Q3").Value For i = LBound(a) To UBound(a) If a(i, 8) = e Then sh.Range("F9").Value = a(i, 2) sh.Range("M9").Value = a(i, 9) Application.Wait Now + TimeValue("00:00:01") Rem sh.PrintOut End If Next i End Sub  
  25. lionheart's post in بحث بالداله match was marked as the answer   
    In worksheet module paste the following code
    Private Sub Worksheet_Change(ByVal Target As Range) Dim x If Target.Row > 4 And Target.Column = 1 Then x = Application.Match(Target.Value, Sheets(2).Columns(1), 0) If Not IsError(x) Then Target.Offset(, 1).Value = Sheets(2).Cells(x, 2).Value End If End If End Sub  
×
×
  • اضف...

Important Information