بحث مخصص من جوجل فى أوفيسنا
Custom Search
|
lionheart
الخبراء-
Posts
664 -
تاريخ الانضمام
-
تاريخ اخر زياره
-
Days Won
27
نوع المحتوي
المنتدى
مكتبة الموقع
معرض الصور
المدونات
الوسائط المتعددة
كل منشورات العضو lionheart
-
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
-
ترحيل الطلبة الراسبة بناء علي مادة الرسوب باستخدام list
lionheart replied to ابو بهاء المصري's topic in منتدى الاكسيل Excel
I have no idea about what you are talking about. Sorry -
ترحيل الطلبة الراسبة بناء علي مادة الرسوب باستخدام list
lionheart replied to ابو بهاء المصري's topic in منتدى الاكسيل Excel
The code is working on all the data regardless the student status -
ترحيل الطلبة الراسبة بناء علي مادة الرسوب باستخدام list
lionheart replied to ابو بهاء المصري's topic in منتدى الاكسيل Excel
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 -
مطلوب كود ترحيل بيانات من شيت الى شيتات متعددة
lionheart replied to ehabaf2's topic in منتدى الاكسيل Excel
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 -
ترحيل الطلبة الراسبة بناء علي مادة الرسوب باستخدام list
lionheart replied to ابو بهاء المصري's topic in منتدى الاكسيل Excel
When executing the code the data will be changed with the next 20 names You can add ActiveSheet.PrintOut line to print the worksheet -
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))
- 1 reply
-
- 2
-
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
-
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
-
ترحيل الطلبة الراسبة بناء علي مادة الرسوب باستخدام list
lionheart replied to ابو بهاء المصري's topic in منتدى الاكسيل Excel
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 -
كود نسخ البيانات من ورقة لورقة اكسل
lionheart replied to خالد المصـــــــــــرى's topic in منتدى الاكسيل Excel
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 -
كود نسخ البيانات من ورقة لورقة اكسل
lionheart replied to خالد المصـــــــــــرى's topic in منتدى الاكسيل Excel
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 -
ترحيل الطلبة الراسبة بناء علي مادة الرسوب باستخدام list
lionheart replied to ابو بهاء المصري's topic in منتدى الاكسيل Excel
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 -
ترحيل الطلبة الراسبة بناء علي مادة الرسوب باستخدام list
lionheart replied to ابو بهاء المصري's topic in منتدى الاكسيل Excel
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 -
ثبيت ازرار التنقل عند النزول لاسفل
lionheart replied to خالد المصـــــــــــرى's topic in منتدى الاكسيل Excel
Maybe someone else will attach the file for you -
ثبيت ازرار التنقل عند النزول لاسفل
lionheart replied to خالد المصـــــــــــرى's topic in منتدى الاكسيل Excel
-
ثبيت ازرار التنقل عند النزول لاسفل
lionheart replied to خالد المصـــــــــــرى's topic in منتدى الاكسيل Excel
I have used simple words and clear steps. Follow the steps one by one -
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
-
ثبيت ازرار التنقل عند النزول لاسفل
lionheart replied to خالد المصـــــــــــرى's topic in منتدى الاكسيل Excel
Select cell A18 View Tab Freeze Panes Freeze Panes -
The code already did that Not clear problem for me. Wait for other members
-
Change the column width and addshape line to suit you
-
Not clear at all You can modify the formula by changing the cell reference
-
هل يمكن استخراج رقم بمواصفات محددة من اكسل؟
lionheart replied to رحااال's topic in منتدى الاكسيل Excel
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 -
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