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

lionheart

الخبراء
  • Posts

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

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

  • Days Won

    28

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

  1. What about the VBA code? Is it working well or not
  2. This formula returns only the results that match the criteria and not all the dates =TEXTJOIN("-",TRUE,IF(الحركة!$A$2:$A$10=A2,الحركة!$F$2:$F$10,""))
  3. Using formulas ------------------- Column F Formula =TEXTJOIN("-",TRUE,IF(الحركة!$A$2:$A$10=A2,الحركة!$F$2:$F$10,"")) Column G Formula =IFERROR(LOOKUP(2,1/(الحركة!$A$2:$A$10=A2),الحركة!$J$2:$J$10),"") Using VBA -------------- Sub Test() Dim ws As Worksheet, sh As Worksheet, rng As Range, n As Long, r As Long Set ws = ThisWorkbook.Worksheets(2) Set sh = ThisWorkbook.Worksheets(3) Set rng = ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).Row) n = sh.Cells(Rows.Count, 1).End(xlUp).Row For r = 2 To n sh.Cells(r, 6).Value = MyVLOOKUP(sh.Cells(r, 1).Value, rng, 6, "-") sh.Cells(r, 7).Value = LookupLast(sh.Cells(r, 1).Value, rng, 10) Next r End Sub Function MyVLOOKUP(ByVal myVal, ByVal rng As Range, ByVal colRef As Long, ByVal myStr As String) If Not IsNumeric(myVal) Then myVal = Chr(34) & myVal & Chr(34) With rng MyVLOOKUP = Join(Filter(.Parent.Evaluate("TRANSPOSE(IF(" & .Columns(1).Address & "=" & myVal & "," & .Columns(colRef).Address & "))"), False, 0), myStr) End With End Function Function LookupLast(ByVal txt As String, ByVal rng As Range, ByVal col As Integer) Dim i As Long For i = rng.Columns(1).Cells.Count To 1 Step -1 If txt = rng.Cells(i, 1) Then LookupLast = rng.Cells(i, col): Exit Function Next i End Function
  4. If Txt3 <> "" Then --------- --------- Else GoTo NXT End If NXT: Dim lastrow As Long
  5. I didn't see that point when started to work on the problem. Generally, it will not be harmful to let the OP try the code too
  6. Rem In UserForm Module Rem ------------------ Private Sub UserForm_Initialize() Dim a With ThisWorkbook.Worksheets(1) a = MergeRanges(.Range("AH2").Resize(Application.CountA(.Columns("AH"))), .Range("W2").Resize(Application.CountA(.Columns("W")))) End With Me.ComboBox1.List = a End Sub Rem In Standard Module Rem ------------------ Function MergeRanges(ParamArray args()) Dim e, cell As Range ReDim temp(0) For Each e In args For Each cell In e If cell <> "" Then temp(UBound(temp)) = cell ReDim Preserve temp(UBound(temp) + 1) End If Next cell Next e ReDim Preserve temp(UBound(temp) - 1) MergeRanges = Application.Transpose(temp) End Function
  7. Sub Test() Dim x, ws As Worksheet, sh As Worksheet, r As Long, m As Long, c As Long, n As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("Sheet1") Set sh = ThisWorkbook.Worksheets("2") With sh.Range("B2").CurrentRegion.Offset(1) .Cells.UnMerge: .ClearContents End With m = 3 For r = 4 To ws.Cells(Rows.Count, "B").End(xlUp).Row sh.Cells(m, 2).Resize(, 2).Value = ws.Cells(r, 2).Resize(, 2).Value n = 4 For c = 4 To 10 Step 2 sh.Cells(m, n).Value = ws.Cells(r, c).Value sh.Cells(m + 1, n).Value = ws.Cells(r, c + 1).Value n = n + 1 Next c sh.Cells(m, 8).Value = ws.Cells(r, 12).Value For Each x In Array(2, 3, 8) sh.Cells(m, x).Resize(2).Merge Next x m = m + 2 Next r Application.ScreenUpdating = True End Sub
  8. Hello Make sure the direction of language is Arabic before copying the codes and also make sure you have installed Arabic from Windows Settings
  9. Sub Test() Const rAddress As String = "A2:J10" Dim ws As Worksheet, sh As Worksheet, r As Range, m As Long Application.ScreenUpdating = False Set sh = ThisWorkbook.Worksheets("ROW") sh.Cells(1).CurrentRegion.Offset(1).ClearContents For Each ws In ThisWorkbook.Worksheets If ws.Name <> sh.Name Then m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 Set r = ws.Range(rAddress) sh.Range("A" & m).Resize(r.Rows.Count, r.Columns.Count).Value = r.Value End If Next ws Application.ScreenUpdating = True End Sub
  10. Sub FilterData() Const txt As String = "Your Filter Criteria Here" Dim m As Long Application.ScreenUpdating = False ClearFilter With ActiveSheet m = .Cells(Rows.Count, 4).End(xlUp).Row .Range("A4:S" & m).AutoFilter 4, txt End With Application.ScreenUpdating = True End Sub Private Sub ClearFilter() With ActiveSheet .AutoFilterMode = False If .FilterMode = True Then .ShowAllData End With End Sub
  11. Worksheet module Private Sub TextBox1_Change() SumInTextBox End Sub Private Sub TextBox2_Change() SumInTextBox End Sub Private Sub TextBox3_Change() SumInTextBox End Sub Sub SumInTextBox() Dim m1 As Double, m2 As Double, m3 As Double m1 = Val(TextBox1.Value) * Range("G4").Value m2 = Val(TextBox2.Value) * Range("G6").Value m3 = Val(TextBox3.Value) * Range("G9").Value TextBox4.Value = m1 + m2 + m3 End Sub
  12. Press Alt + F8 and run the code Test Report.xlsm
  13. Remove extra spaces in the months in column A then use this formula =NETWORKDAYS.INTL(1&D4,EOMONTH(1&D4,0),"1111011")
  14. Sub Test() [B6] = GetDupUniq([B3], True) [B9] = GetDupUniq([B3], False) End Sub Function GetDupUniq(ByVal txt As String, ByVal f As Boolean) As String Dim e, s As String, i As Long With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To Len(txt) s = Mid$(txt, i, 1) If s <> " " Then .Item(s) = .Item(s) + 1 Next i For Each e In .Keys If (f = True And .Item(e) = 1) Or (f = False And .Item(e) > 1) Then .Remove e Next e GetDupUniq = Join(.Keys, "-") End With End Function
  15. Sub Test() Const col As Integer = 3 Dim a, e, dic As Object, k As String, i As Long Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") With Sheets(1).Range("A1:AA" & Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row) a = .Columns(col).Resize(, 2).Value For i = 6 To UBound(a, 1) k = a(i, 1) & Space(1) & a(i, 2) If Not dic.Exists(k) Then Set dic(k) = Union(.Rows("1:5"), .Rows(i)) Else Set dic(k) = Union(dic(k), .Rows(i)) End If Next i End With For Each e In dic If Not Evaluate("ISREF('" & e & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = e End If With Sheets(e) .DisplayRightToLeft = True .UsedRange.Clear dic(e).Copy .Cells(1) .Columns.AutoFit End With Next e Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Delete the columns from column AB to column AK first then run the code 1تقرير كامل تشغيل.xlsm
  16. To restrict textbox to numbers only Private Sub TextBox16_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) Select Case KeyAscii Case Asc("0") To Asc("9") Case Asc("-") If InStr(1, TextBox16.Text, "-") > 0 Or TextBox16.SelStart > 0 Then KeyAscii = 0 End If Case Asc(".") If InStr(1, TextBox16.Text, ".") > 0 Then KeyAscii = 0 End If Case Else KeyAscii = 0 End Select End Sub As for the other notes, the code is working with no problems
  17. Sub Test() Dim ws As Worksheet, sh As Worksheet, m As Long Application.ScreenUpdating = False Set ws = Sheet1 Set sh = Sheet5 m = ws.Cells(Rows.Count, 2).End(xlUp).Row ws.Range("A3:H" & m).Copy sh.Range("A3").PasteSpecial xlPasteValues Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
  18. Sub Test() With ActiveSheet .PageSetup.CenterFooter = Format(Date, "dd-mm-yyyy") .PrintPreview End With End Sub
  19. Option Explicit Const col As Long = 4 Private Sub UserForm_Initialize() Dim i As Long With ThisWorkbook.Worksheets(1) If Application.WorksheetFunction.Count(.Columns(col)) > 1 Then For i = 2 To .Cells(Rows.Count, col).End(xlUp).Row ListBox3.AddItem .Cells(i, col).Value Next i End If End With TextBox16.SetFocus End Sub Private Sub TextBox16_Exit(ByVal Cancel As MSForms.ReturnBoolean) Dim m As Long If IsNumeric(TextBox16.Value) Then With ThisWorkbook.Worksheets(1) If .Cells(1, col).Value = "" Then .Cells(1, col).Value = Label29.Caption m = .Cells(Rows.Count, col).End(xlUp).Row + 1 .Cells(m, col).Value = TextBox16.Value End With End If With TextBox16 ListBox3.AddItem .Value .Value = Empty TextBox15.Value = ListBox3.ListCount Cancel = True End With End Sub
  20. Private Sub TextBox16_Exit(ByVal Cancel As MSForms.ReturnBoolean) Const col As Long = 6 Dim m As Long If IsNumeric(TextBox16.Value) Then With ThisWorkbook.Worksheets(1) If .Cells(1, col).Value = "" Then .Cells(1, col).Value = Label29.Caption m = .Cells(Rows.Count, col).End(xlUp).Row + 1 .Cells(m, col).Value = TextBox16.Value End With End If With TextBox16 ListBox3.AddItem .Value .Value = Empty Cancel = True End With End Sub
  21. Sub Test() With Range("H1", Range("H" & Rows.Count).End(xlUp)) .AutoFilter 1, "<0" .Offset(1).EntireRow.Delete .AutoFilter End With End Sub
  22. Sub Test() Dim a, ws As Worksheet, sh As Worksheet, m As Long, n As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) m = ws.Cells(Rows.Count, 3).End(xlUp).Row n = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 a = Array(Format(ws.Range("H3").Value, "yyyy/mm/dd"), ws.Range("I2").Value, ws.Range("D3").Value) sh.Range("A" & n).Resize(m - 5, 3).Value = a sh.Range("D" & n).Resize(m - 5, 7).Value = ws.Range("C6").Resize(m - 5, 7).Value Application.ScreenUpdating = True End Sub
  23. Function DigitalRoot(num As String) As Long Dim t As Double t = Val(num) DigitalRoot = IIf(t > 0, 1 + (t - 1) - 9 * Int((t - 1) / 9), 0) End Function =1+MOD(A1-1,9)
×
×
  • اضف...

Important Information