lionheart

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

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

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

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

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

What about Application.SendKeys "^f" DoEvents SendKeys "{NUMLOCK}{NUMLOCK}"

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

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)

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

There a re alot of named ranges in Name Manager (Formulas Tab) Do you need them as they are related to worksheets not exist in your workbook If you are interested in breaking links you should get rid of such named ranges if they are not necessary for you

In worksheet module Private Sub Worksheet_Change(ByVal Target As Range) Dim v If Target.Address = "$B$2" Then v = Target.Value Rows("15:200").Hidden = False If v = 0 Then Rows("15:200").Hidden = True ElseIf v = Range("N67").Value Then Rows("51:200").Hidden = True ElseIf v = Range("N68").Value Then Rows("15:50").Hidden = True Rows("71:200").Hidden = True ElseIf v = Range("N69").Value Then Rows("15:70").Hidden = True Rows("151:200").Hidden = True ElseIf v = Range("N70").Value Then Rows("15:150").Hidden = True End If End If End Sub

Wait for someone to attach the file for you. I don't attach files You have to apply the steps by yourself. Sorry for that

Move the school logo as shown and rename it [School_Logo] 01 Modify the following parts in the code Sub kh_AutoFill(R As Integer) Dim SourceRange As Range, fillRange As Range, RR As Long, i As Long, j As Long RR = (R * CountRow) With MySheet Set SourceRange = .Rows(FirstRow).Resize(CountRow) Set fillRange = .Rows(FirstRow).Resize(RR) SourceRange.AutoFill fillRange, xlFillDefault For i = FirstRow To (FirstRow + RR - 1) Step CountRow j = (i - FirstRow) / CountRow + 1 .Shapes("School_Logo").Copy .Cells(i + 1, "O").PasteSpecial xlPasteAll .Shapes(.Shapes.Count).Name = "LH_Logo_" & j Next i .PageSetup.PrintArea = .Range("B" & FirstRow).Resize(RR, CountColumn).Address End With End Sub Also modify the following Sub Kh_Picture_Delete(MySh As Worksheet) On Error Resume Next Dim shp As Shape For Each shp In MySh.Shapes If shp.Name Like "KHK_*" Or shp.Name Like "LH_Logo_*" Then shp.Delete End If Next shp On Error GoTo 0 End Sub

Another solution Format the numbers on the worksheet with the following custom format [$-,201]0 then modify this line Controls("TextBox" & j).Text = Cells(ListBox1.List(i, 1), j).Text

In standard module Function ConvertToArabicNumber(ByVal num As String) As String Dim s As String, d As String, i As Long For i = 1 To Len(num) d = Mid(num, i, 1) s = s & ChrW(&H660 + Val(d)) Next i ConvertToArabicNumber = s End Function In the userform module modify the following procedure Private Sub ListBox1_Click() For i = 0 To ListBox1.ListCount If ListBox1.Selected(i) = True Then For j = 1 To 61 Controls("TextBox" & j).Text = ConvertToArabicNumber(Cells(ListBox1.List(i, 1), j)) Next j r = ListBox1.List(i, 1) Exit For End If Next i End Sub

this line will store any row that doesn't have the text .....If sh.Cells(r, "AN").Value <> Join(Array(C

Hope this help you Sub Test() Const SROW As Long = 7 ' Start row constant, set to row 7 Dim ws As Worksheet, sh As Worksheet, rng As Range, lr As Long, r As Long Application.ScreenUpdating = False ' Disable screen updating to improve performance With ThisWorkbook Set ws = .Worksheets(1): Set sh = .Worksheets(2) ' Set variables ws and sh to the first and second worksheets in the workbook, respectively End With sh.Rows(SROW & ":" & Rows.Count).Cells.Clear ' Clear all cells in rows from SROW to the last row in worksheet sh lr = ws.Cells(Rows.Count, "C").End(xlUp).Row ' Find the last used row in column C of worksheet ws If lr < SROW Then Exit Sub ' If the last used row is less than the start row, exit the subroutine ws.Range("A" & SROW & ":G" & lr).Copy sh.Range("A" & SROW) ' Copy the range from column A to G, starting from SROW to lr, from worksheet ws to worksheet sh ws.Range("AN" & SROW & ":AN" & lr).Copy sh.Range("AN" & SROW) ' Copy the range in column AN, starting from SROW to lr, from worksheet ws to worksheet sh For r = SROW To lr ' Loop through each row from SROW to lr If sh.Cells(r, "AN").Value <> Join(Array(Chr(207), Chr(230), Chr(209), Chr(32), Chr(203), Chr(199), Chr(228), Chr(237)), Empty) Then ' Check if the value in column AN of the current row in worksheet sh is not equal to the joined characters If rng Is Nothing Then Set rng = sh.Rows(r) Else Set rng = Union(rng, sh.Rows(r)) ' If rng is Nothing, set rng to the current row, otherwise, combine rng with the current row using the Union function End If Next r If Not rng Is Nothing Then rng.EntireRow.Delete ' If rng is not Nothing (i.e., there are rows to be deleted), delete the entire rows of rng lr = sh.Cells(Rows.Count, "C").End(xlUp).Row ' Find the last used row in column C of worksheet sh If lr < SROW Then Exit Sub ' If the last used row is less than the start row, exit the subroutine sh.Range("A" & SROW).Resize(lr - SROW + 1).Value = Evaluate("ROW(1:" & lr - SROW + 1 & ")") ' Populate the range starting from cell A7 to the last used row in column C of worksheet sh with the row numbers using the Evaluate function Application.ScreenUpdating = True ' Enable screen updating End Sub

Try this code. Copy the headers manually first. The code will put the results at row 7 as start point Sub Test() Const SROW As Long = 7 Dim ws As Worksheet, sh As Worksheet, rng As Range, lr As Long, r As Long Application.ScreenUpdating = False With ThisWorkbook Set ws = .Worksheets(1): Set sh = .Worksheets(2) End With sh.Rows(SROW & ":" & Rows.Count).Cells.Clear lr = ws.Cells(Rows.Count, "C").End(xlUp).Row If lr < SROW Then Exit Sub ws.Range("A" & SROW & ":G" & lr).Copy sh.Range("A" & SROW) ws.Range("AN" & SROW & ":AN" & lr).Copy sh.Range("AN" & SROW) For r = SROW To lr If sh.Cells(r, "AN").Value <> Join(Array(Chr(207), Chr(230), Chr(209), Chr(32), Chr(203), Chr(199), Chr(228), Chr(237)), Empty) Then If rng Is Nothing Then Set rng = sh.Rows(r) Else Set rng = Union(rng, sh.Rows(r)) End If Next r If Not rng Is Nothing Then rng.EntireRow.Delete lr = sh.Cells(Rows.Count, "C").End(xlUp).Row If lr < SROW Then Exit Sub sh.Range("A" & SROW).Resize(lr - SROW + 1).Value = Evaluate("ROW(1:" & lr - SROW + 1 & ")") Application.ScreenUpdating = True End Sub

In ThisWorkbook Module Private Sub Workbook_Open() Application.OnKey "{F9}", "TestMacro" End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.OnKey "{F9}" End Sub In Standard Module Sub TestMacro() Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("Qution") ws.Range("G17").Value = Empty: ws.Range("D17").Value = Empty With ws.Range("D17") .Formula = "=RANDBETWEEN(data1!A1,data1!A30)" .Value = .Value End With With Application .ScreenUpdating = True .EnableEvents = False .Calculation = xlCalculationManual .Wait Now + TimeValue("00:00:05") ws.Range("G17").Formula = "=LOOKUP(D17,data1!A1:A730,data1!F1:F30)" .Calculate .Calculation = xlCalculationAutomatic .EnableEvents = True End With End Sub