lionheart
الخبراء-
Posts
649 -
تاريخ الانضمام
-
تاريخ اخر زياره
-
Days Won
27
lionheart last won the day on يونيو 24 2023
lionheart had the most liked content!
السمعه بالموقع
929 Excellentعن العضو lionheart
البيانات الشخصية
-
Gender (Ar)
ذكر
-
Job Title
Programmer
-
البلد
Egypt
-
الإهتمامات
Programming
اخر الزوار
بلوك اخر الزوار معطل ولن يظهر للاعضاء
-
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
-
Here's a modification to let empty row between results but I won't merge cells Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, i 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 Application.ScreenUpdating = False 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 If lr = r Then Exit For sh.Cells(m, 1).Resize(, 4).Interior.Color = vbMagenta m = m + 1 End If Next r Application.ScreenUpdating = True End Sub
-
Delete the rows in sheet2 from row 5 to row 25 then try this code Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, i 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 Application.ScreenUpdating = False 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 End If Next r Application.ScreenUpdating = True End Sub I didn't merge the cells as it is not practical
-
Whar are the expected correct results exactly I have tried UDF on my side and these are the results 04-11-04 04-11-00 04-10-30 04-10-29 04-10-28 04-10-27 04-10-26
-
مطلوب كود إخفاء أسطر بشرط موجود فى خلية
lionheart replied to يوسف عطا's topic in منتدى الاكسيل Excel
You can execute the code in the worksheet event but I think it is better to execute the code for once when you would like to change -
مطلوب كود إخفاء أسطر بشرط موجود فى خلية
lionheart replied to يوسف عطا's topic in منتدى الاكسيل Excel
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 -
Is this problem related to a specific workbook or any workbook Attach the file if it is related to a sepcific workbook
- 1 reply
-
- 1
-
What about Application.SendKeys "^f" DoEvents SendKeys "{NUMLOCK}{NUMLOCK}"
-
محتاج كود ترحيل تقيم الطلاب من جدول الى جدول اخر
lionheart replied to ehabaf2's topic in منتدى الاكسيل Excel
This line Application.Goto .Range("AM" & m), True is used to go to specific range. At the end of the code if the transfer process happens, excel will go to column AM at the row m so it is useful to see the results of the code -
محتاج كود ترحيل تقيم الطلاب من جدول الى جدول اخر
lionheart replied to ehabaf2's topic in منتدى الاكسيل Excel
It is just one line of code and you can do it yourself. Refer to the desired range using Range property like that Range("A1:C10") Of course change the reference to the reference you need then use ClearContents method so the line should look like that Range("A1:C10").ClearContents The line will be added to the end of the code after trasnferring data before this line Application.Goto .Range("AM" & m), True Don't forget to change the reference A1 to C10 to the range you desire to clear its contents which should be F10:O & the last row (lr variable) -
محتاج كود ترحيل تقيم الطلاب من جدول الى جدول اخر
lionheart replied to ehabaf2's topic in منتدى الاكسيل Excel
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 -
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))
-
Try Private Sub CommandButton1_Click() Dim mySum As Double, i As Long With Me.ListBox1 For i = 0 To .ListCount - 1 mySum = mySum + Val(.List(i, 1)) Next i End With Me.TextBox1.Value = mySum End Sub