lionheart

Private Sub CommandButton1_Click() Dim ws As Worksheet, lastRow As Long, rRow As Long, last As Integer, LS1 As Integer, LAS2 As Integer If Evaluate("ISREF('" & ComboBox6.Value & "'!A1)") Then Set ws = ThisWorkbook.Worksheets(ComboBox6.Value) Else MsgBox "Target Worksheet Not Found", vbExclamation: Exit Sub End If With ws .Activate rRow = .Cells(1, 1).CurrentRegion.Rows.Count + 1 last = .Range("A10000").End(xlUp).Row + 1 For i = 0 To ListBox1.ListCount - 1 .Cells(last, "F").Value = Me.ListBox1.List(i, 0) .Cells(last, "G").Value = Me.ListBox1.List(i, 1) .Cells(last, "H").Value = Me.ListBox1.List(i, 2) .Cells(last, "I").Value = Me.ListBox1.List(i, 3) last = last + 1 Next i LS1 = .Range("A10000").End(xlUp).Row + 1 ls2 = .Range("F10000").End(xlUp).Row For S = LS1 To ls2 .Cells(LS1, "A").Value = Me.TextBox1.Value .Cells(LS1, "b").Value = Me.ComboBox5.Value .Cells(LS1, "C").Value = Me.TextBox2.Value .Cells(LS1, "D").Value = Me.ComboBox4.Value Sheet2.Cells(LS1, "E").Value = Me.ComboBox5.Value LS1 = LS1 + 1 Next S End With MsgBox "Data Added Successfully", 64 End Sub

I already did. Review the previous post

In cell B7 =TRIM(MID(SUBSTITUTE($A7, "-", REPT(" ", 100)), 100*COLUMNS($B1:B1) - 99, 100)) In cell C7 =TRIM(MID(SUBSTITUTE($A7, "-", REPT(" ", 100)), 100*COLUMNS($B1:C1) - 99, 100)) In cell E7 =TRIM(MID(SUBSTITUTE($A7, "-", REPT(" ", 100)), 100*COLUMNS($B1:D1) - 99, 100)) In cell F7 =SUBSTITUTE(TRIM(MID(SUBSTITUTE($A7, "-", REPT(" ", 100)), 100*COLUMNS($B1:E1) - 99, 100)),".pdf","") But using the code is easier and cleaner and you ust get the values

Sub Test() Dim v, r As Long, i As Long, m As Long m = Cells(Rows.Count, 1).End(xlUp).Row Range("B7:F" & m).NumberFormat = "@" For r = 7 To m v = Split(Replace(Cells(r, 1).Value, ".pdf", ""), "-") For i = 0 To 3 If i > 1 Then Cells(r, i + 3).Value2 = CStr(v(i)) Else Cells(r, i + 2).Value = CStr(v(i)) Next i Next r End Sub

Put the following code in worksheet module Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$B$2" Then Application.EnableEvents = False Range("I19").ClearContents On Error Resume Next If Range("H19").Value > 0 Then Range("I19").Value = Range("H19").Value On Error GoTo 0 Application.EnableEvents = True End If End Sub

Sub Test() Dim ws As Worksheet, sh As Worksheet, r As Range, d As Object, i As Long Application.ScreenUpdating = False Set ws = Sheets(1): Set sh = Sheets(2) Set d = CreateObject("Scripting.Dictionary") With ws Set r = .Range("B4:BF" & .Cells(Rows.Count, 3).End(xlUp).Row) For Each r In Intersect(r, r.Offset(1, 2)) If r.Value <> "" Then i = r.Row d(.Cells(i, 2) & .Cells(i, 3) & r) = Array(.Cells(i, 2), .Cells(i, 3), r) End If Next r End With With sh .Range("C3:BE15").ClearContents .Range("BK1").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.Items)) .Range("BN1:BN" & d.Count).Formula = "=BL1&BM1" With .Range("C3:BE15") .Formula = "=IFERROR(INDEX($BK:$BK,MATCH($B3&C$2,$BN:$BN,0)),"""")" .Value = .Value End With .Columns("BK:BN").ClearContents End With Application.ScreenUpdating = True End Sub

You can simply use the Copy method if you just want to copy data for once. I think you have to explain your question well

Sub Test() Const sOutput As String = "Output" Dim shp As Shape, m As Long, r As Long, n As Long Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next: Sheets(sOutput).Delete: On Error GoTo 0 Application.DisplayAlerts = True Sheets(1).Copy , Sheets(Sheets.Count) Sheets(Sheets.Count).Name = sOutput With Sheets(sOutput) For Each shp In .Shapes shp.Delete Next shp .AutoFilterMode = False If .FilterMode = True Then .ShowAllData m = .Cells(Rows.Count, 1).End(xlUp).Row .Range("A1:H" & m).Sort Key1:=.Range("G1:G" & m), Order1:=xlAscending, Header:=xlYes r = 2 Do Until .Cells(r, 7).Value = Empty If r = 2 Then n = r If .Cells(r, 7).Value <> .Cells(r + 1, 7).Value Then .Rows(r + 1).Insert Shift:=xlDown .Cells(r + 1, 7).Value = "Total" .Cells(r + 1, 8).Formula = "=SUM(H" & n & ":H" & r & ")" With .Cells(r + 1, 7).Resize(, 2) .Font.Color = vbWhite .Interior.Color = RGB(55, 86, 36) End With r = r + 1 n = r + 1 End If r = r + 1 Loop End With Application.ScreenUpdating = True End Sub

You can use a helper column to put the results of the code posted here then simply copy the first 20 record to the first table and copy the second 20 record to the second table

Try it yourself. Study the code well then try to implement and show us your tries

Select the cells that have the Hijri dates which are D18 & E18 and right-click to select Format Cells From Number tab select Date and from Calendar type select "Hijri" and check the option (input dates according to selected calendar) that's all Maybe you need to double click the cells D18 and E18 to recalculate the formulas

Great solution but the heavy use of conditional formatting will make the file slow and heavy and at the same time will make the file size larger

Sub Test() Dim v, x, arr, ws As Worksheet, sh As Worksheet, p As Single, l As Long, lr As Long, ii As Long, k As Long Set ws = ThisWorkbook.Worksheets("Sheet1") Set sh = ThisWorkbook.Worksheets("Sheet2") p = 0.1 lr = ws.Range("A" & Rows.Count).End(xlUp).Row v = ws.Range("A1").Resize(lr).Value2 ReDim w(1 To UBound(v) * p, 0) ReDim arr(1 To Int(UBound(v) * p), 1 To 7) For l = 1 To UBound(w) w(l, 0) = v(Application.RandBetween((l - 1) * 1 / p + 1, l * 1 / p), 1) x = Application.Match(Val(w(l, 0)), ws.Columns(1), 0) If Not IsError(x) Then k = k + 1 For ii = LBound(arr, 2) To UBound(arr, 2) arr(k, ii) = ws.Cells(x, ii).Value Next ii End If Next l sh.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr End Sub

Sub Test() Const sRow As Integer = 4, eRow As Integer = 18 Dim x, r As Long, cnt As Long Application.ScreenUpdating = False With ActiveSheet For r = sRow To eRow cnt = cnt + 1 x = Application.Match(.Cells(r, 2).Value, .Columns(14), 0) If Not IsError(x) Then .Cells(x, 14).Resize(, 11).Cut If r <> x Then .Cells(r, 14).Insert Shift:=xlDown Else .Cells(r, 2).Resize(, 11).Cut .Cells(.Cells(Rows.Count, 2).End(xlUp).Row + 1, 2).Insert Shift:=xlDown If cnt = eRow Then Exit For r = r - 1 End If Next r End With Application.ScreenUpdating = True End Sub

Great my bro but the borders are not accurate as for using the conditional formatting. But I like your way of thinking

Sub Test() Dim c As Range, rFirst As Range Application.ScreenUpdating = False With ActiveSheet .Columns("A:H").Borders.Value = 0 Set c = .Columns(1).Find(.Range("A2").Value) If rFirst Is Nothing Then Set rFirst = c Do While Not c Is Nothing c.CurrentRegion.Borders.Value = 1 Set c = .Columns(1).FindNext(After:=c) If c.Address = rFirst.Address Then Exit Do Loop Range("A1:H1").Borders.Value = 0 End With Application.ScreenUpdating = True End Sub

This is a better version If the record doesn't exist in the two tables the record will be colored with yellow and if there are two records with the same id vbCyan will be the color for different information if exists Sub Test() Const sRow As Integer = 4, eRow As Integer = 18 Dim x, y, r As Long, c As Long Application.ScreenUpdating = False With ActiveSheet .Range("B4").CurrentRegion.Sort Key1:=.Range("B4"), Order1:=xlAscending, Header:=xlNo .Range("N4").CurrentRegion.Sort Key1:=.Range("N4"), Order1:=xlAscending, Header:=xlNo .Rows(sRow & ":" & eRow).Interior.Color = xlNone For r = sRow To eRow x = Application.Match(.Cells(r, 2).Value, .Columns(14), 0) If Not IsError(x) Then For c = 2 To 12 If .Cells(r, c).Value <> .Cells(x, c + 12).Value Then If .Cells(r, c).Interior.Color <> vbYellow Then .Cells(r, c).Interior.Color = vbCyan If .Cells(x, c + 12).Interior.Color <> vbYellow Then .Cells(x, c + 12).Interior.Color = vbCyan End If Next c Else .Cells(r, 2).Resize(, 11).Interior.Color = vbYellow End If y = Application.Match(.Cells(r, 14).Value, .Columns(2), 0) If Not IsError(y) Then For c = 2 To 12 If .Cells(y, c).Value <> .Cells(r, c + 12).Value Then If .Cells(y, c).Interior.Color <> vbYellow Then .Cells(y, c).Interior.Color = vbCyan If .Cells(r, c + 12).Interior.Color <> vbYellow Then .Cells(r, c + 12).Interior.Color = vbCyan End If Next c Else .Cells(r, 14).Resize(, 11).Interior.Color = vbYellow End If Next r End With Application.ScreenUpdating = True End Sub

Not so clear but try this code Sub Test() Const sRow As Integer = 4, eRow As Integer = 18 Dim r As Long, c As Long Application.ScreenUpdating = False With ActiveSheet .Range("B4").CurrentRegion.Sort Key1:=.Range("B4"), Order1:=xlAscending, Header:=xlNo .Range("N4").CurrentRegion.Sort Key1:=.Range("N4"), Order1:=xlAscending, Header:=xlNo .Rows(sRow & ":" & eRow).Interior.Color = xlNone For r = sRow To eRow For c = 2 To 12 If .Cells(r, c).Value <> .Cells(r, c + 12).Value Then .Cells(r, c).Interior.Color = vbCyan .Cells(r, c + 12).Interior.Color = vbCyan End If Next c Next r End With Application.ScreenUpdating = True End Sub

The code is already there in ThisWorkbook module Private Sub Workbook_Open() Application.Visible = False frm_Inventory_Management.Show End Sub

Sub Test() Dim Last As Long, i As Long Last = Sheet4.Range("A100000").End(xlUp).Row + 1 For i = 1 To 7 Sheet4.Cells(Last, i).Value = Me.Controls("TextBox" & i + 1).Value Next i End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim sh As Long, v As Long, r As Long, lr As Long, i As Long, ii As Long If Target.Address = "$Q$4" Then Application.ScreenUpdating = False Application.EnableEvents = False Range("A10:T60000") = "" sh = Worksheets.Count: v = 10 For r = 1 To sh If Sheets(r).Name <> ActiveSheet.Name Then lr = Sheets(r).Range("i" & Rows.Count).End(xlUp).Row For i = 10 To lr If Range("Q4") = Sheets(r).Cells(i, 9) Then Cells(v, 1).Resize(, 20).Value = Sheets(r).Cells(i, 1).Resize(, 20).Value v = v + 1 End If Next i End If Next r Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub

Try to increase the variable m by two instead of 1 to be like that m = m + 2

Sub Test() Dim ws As Worksheet, sh As Worksheet, r As Long, m As Long, n As Long Application.ScreenUpdating = False Set ws = Sheet1: Set sh = Sheet4 m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 n = m For r = 5 To ws.Cells(Rows.Count, 1).End(xlUp).Row If ws.Cells(r, 1).Value <> "" And ws.Cells(r, 1).Value <> ws.Range("A4").Value Then sh.Cells(m, 1).Resize(, 12).Value = ws.Cells(r, 1).Resize(, 12).Value m = m + 1 End If Next r sh.Range("A" & n - 2 & ":L" & n - 1).Copy sh.Range("A" & n & ":L" & m - 1).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Sub Rename_Worksheets() Dim i As Long For i = 1 To Sheets.Count If Worksheets(i).Name <> "Sheet2" And Worksheets(i).Name <> "Sheet4" Then If Worksheets(i).Range("N14").Value <> "" Then Sheets(i).Name = Worksheets(i).Range("n14").Value End If End If Next i End Sub

Replace "Sales Bill" in th code with the Arabic characters Sub Test() Dim x, ws As Worksheet, sh As Worksheet, r As Long, lr As Long Set ws = Sheet5: Set sh = Sheet8 For r = 5 To ws.Cells(Rows.Count, "G").End(xlUp).Row If ws.Cells(r, 7).Value = "Sales Bill" Then ws.Cells(r, 11).Value = "Sales Bill" Else x = Application.Match(ws.Cells(r, 8).Value, sh.Columns(3), 0) If Not IsError(x) Then ws.Cells(r, 11).Value = sh.Cells(x, 4).Value End If End If Next r End Sub