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

lionheart

الخبراء
  • Posts

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

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

  • Days Won

    27

كل منشورات العضو lionheart

  1. Select the drop down form control and rename it [myDropDown] in the Name Box Then put the following code in a standard module Sub Fill_DropDown_Form_Control() Dim ws As Worksheet, sh As Worksheet, myDrop As dropDown, r As Long, i As Long With ThisWorkbook Set ws = .Worksheets("1"): Set sh = .Worksheets(Join(Array(Chr(211), Chr(204), Chr(225), Chr(49)), Empty)) End With Set myDrop = sh.DropDowns("myDropDown") ReDim a(1 To 100) For r = 8 To ws.Range("I3").Value + 7 If ws.Cells(r, "K").Value = sh.Range("U1").Value Then i = i + 1 a(i) = ws.Cells(r, "C").Value End If Next r myDrop.RemoveAllItems If i > 0 Then ReDim Preserve a(1 To i) myDrop.List = a End If End Sub You have to put the grade in specific cell say cell U1 in the same worksheet of the drop down and also put the following code in the worksheet module Private Sub Worksheet_SelectionChange(ByVal Target As Range) Range("B1") = ActiveCell.Row End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$U$1" Then Call Fill_DropDown_Form_Control End Sub so simply to use the code, type the grade you want in cell U1 then the drop down will be filled with the names related to that grade
  2. Never mind my bro Abdullah Out target is not to get the best solution but to help others as possible as we can May Allah bless you
  3. Try Sub Test() Const COLTARGET As Long = 3 Dim a, ws As Worksheet, sh As Worksheet, r As Range, i As Long, n As Long With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual End With Set ws = ThisWorkbook.Worksheets("Sheet1") With ws.Range("A3").CurrentRegion Set r = .Offset(, .Columns.Count + 2).Cells(1) .Columns(COLTARGET).AdvancedFilter 2, , r, True a = r.CurrentRegion.Value: r.CurrentRegion.Clear For i = 2 To UBound(a, 1) ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count): Set sh = ActiveSheet: sh.Name = a(i, 1) sh.Range("A1").Value = a(i, 1) sh.Range("A3").CurrentRegion.Clear .AutoFilter COLTARGET, a(i, 1) .Copy sh.Range("A4") n = sh.Range("A4").CurrentRegion.Rows.Count - 1 sh.Range("A5").Resize(n).Value = Evaluate("ROW(1:" & n & ")") .AutoFilter Next i End With With Application .Calculation = xlCalculationAutomatic: .EnableEvents = True: .ScreenUpdating = True End With End Sub
  4. When executing the code the data will be changed with the next 20 names You can add ActiveSheet.PrintOut line to print the worksheet
  5. In cell D4 enter the formula =IF(MOD(C4,500)=0, C4/500*5, (INT(C4/500)+1)*5) for office 365 users =LET(div, C4/500, IF(MOD(C4,500)=0, div*5, (INT(div)+1)*5))
  6. 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
  7. 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
  8. No need to add this line to worksheet module Get_Data_By_Subject The code should be assigned to the spinner. After selecting the subject directly, click on the down arrow then use up arrow
  9. I don't attach files if you don't know how to copy the code and use it, you have to learn the basics first before posting a question
  10. In the first sheet module paste the following code Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet, sh As Worksheet, rng As Range, lr As Long If Target.Row > 6 And Target.Column < 10 Then Application.ScreenUpdating = False With ThisWorkbook Set ws = .Worksheets(1): Set sh = .Worksheets(2) End With lr = ws.Cells(Rows.Count, "C").End(xlUp).Row If lr >= 7 Then Set rng = ws.Range("D7:J" & lr) With rng Rem sh.Range("A6").Resize(.Rows.Count, .Columns.Count).Value = rng.Value rng.Copy sh.Range("A6") End With End If Application.ScreenUpdating = True End If End Sub the code will be executed as soon as you changed any cell in the range
  11. I don't attach files Wait someone to attach the file for you Just follow the steps and you will be able to make it run properly
  12. The file is not perfect. Generally try the following code In standard module paste the following code Option Explicit Sub Get_Data_By_Subject() Const FIXEDROWS As Long = 20, FIXEDCOLS As Long = 5 Dim a, v, xCol, ws As Worksheet, sh As Worksheet, rng As Range, i As Long, ii As Long, k As Long, iStart As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False With ThisWorkbook Set ws = .Worksheets("ola"): Set sh = .Worksheets("lagna") End With a = ws.Range("B6:T102").Value ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) xCol = Application.Match(sh.Range("L3").Value, ws.Rows(5), 0) If Not IsError(xCol) Then For i = LBound(a) To UBound(a) If a(i, xCol - 1) <> Empty Then k = k + 1 For ii = LBound(a, 2) To UBound(a, 2) b(k, ii) = a(i, ii) Next ii End If Next i If k > 0 Then iStart = IIf(sh.Range("B9").Value = Empty, 1, sh.Range("B9").Value) Set rng = sh.Range("C9").Resize(FIXEDROWS, FIXEDCOLS) If iStart > k Then rng.ClearContents: GoTo Skipper v = ExtractArray(b, iStart, FIXEDROWS, FIXEDCOLS) sh.Range("B9").Resize(FIXEDROWS).Value = Evaluate("ROW(" & iStart & ":" & iStart + FIXEDROWS - 1 & ")") With rng .ClearContents .Value = v End With End If End If Skipper: Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Application.ScreenUpdating = True End Sub Function ExtractArray(ByVal arr, ByVal iStart As Long, ByVal iRows As Long, ByVal iCols As Long) Dim i As Long, ii As Long ReDim outputArr(1 To iRows, 1 To iCols) For i = iStart To iStart + iRows - 1 For ii = 1 To iCols outputArr(i - iStart + 1, ii) = arr(i, ii) Next ii Next i ExtractArray = outputArr End Function In worksheet named Lagna paste the following module Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$L$3" Then Application.ScreenUpdating = False Range("B9:I28").ClearContents Application.ScreenUpdating = True End If End Sub By the way after selecting the subject click the down arrow of the spinner not the up arrow
  13. 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
  14. I have used simple words and clear steps. Follow the steps one by one
  15. 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. The code already did that Not clear problem for me. Wait for other members
  17. Change the column width and addshape line to suit you
  18. Not clear at all You can modify the formula by changing the cell reference
  19. Great my bro That is my try Sub Test() Call Generate_Random_Numbers Call Extract_Valid_Numbers_Only End Sub Private Sub Generate_Random_Numbers() Dim i As Long With ActiveSheet With .Columns("A:B") .ClearContents: .NumberFormat = "@": .ColumnWidth = 20 End With .Range("A1").Resize(, 2).Value = Array("Numbers", "Result") ReDim a(1 To 100, 1 To 1) For i = LBound(a) To UBound(a, 1) a(i, 1) = GenerateNumber() Next i .Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a End With End Sub Function GenerateNumber() As String Dim a, sRanNum As String, sPrefix As String, iLen As Long a = Array("02", "05") iLen = WorksheetFunction.RandBetween(8, 11) sPrefix = a(WorksheetFunction.RandBetween(0, UBound(a))) sRanNum = sPrefix & Format(Application.WorksheetFunction.RandBetween(10 ^ (iLen - 3), (10 ^ (iLen - 2)) - 1), String(iLen - 2, "0")) GenerateNumber = sRanNum End Function Private Sub Extract_Valid_Numbers_Only() Dim a, ws As Worksheet, n As Long, i As Long Set ws = ActiveSheet a = ws.UsedRange.Columns(1).Value ReDim b(1 To UBound(a, 1), 1 To 1) n = 1 With CreateObject("VBScript.RegExp") .Global = True For i = 1 To UBound(a, 1) .Pattern = "^05\d{8}$" If .Test(a(i, 1)) Then b(n, 1) = .Execute(a(i, 1))(0).Value n = n + 1 End If Next i End With ws.Range("B2").Resize(UBound(b, 1), UBound(b, 2)).Value = b End Sub There are two codes: the first code will generate random numbers and the second code will extract the valid numbers only
  20. 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
×
×
  • اضف...

Important Information