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

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

اخر الزوار

بلوك اخر الزوار معطل ولن يظهر للاعضاء

  1. 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
  2. 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
  3. 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
  4. 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
  5. You have to create another worksheet and attach the file again with clear logic of what you are trying to do exactly Will the items be listed in the new worksheet or what
  6. In cell B15 put the following formulas and drag to left =INDEX(OFFSET($E6, 1, 0, 1, COLUMNS($E6:$BH6)), MATCH(B14, OFFSET($E6, 0, 0, 1, COLUMNS($E6:$BH6)), 0)) then select the range B15:F15 and copy the range and finally paste the formulas into cells B17 then B19
  7. 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
  8. 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
  9. What about Application.SendKeys "^f" DoEvents SendKeys "{NUMLOCK}{NUMLOCK}"
  10. 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
  11. 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)
  12. 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
  13. 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))
  14. 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
×
×
  • اضف...

Important Information