lionheart

Sub Test() Dim c As Long, r As Long With ActiveSheet.UsedRange .Cells.EntireRow.Hidden = False .Cells.EntireColumn.Hidden = False For r = 1 To .Rows.Count If Application.CountA(.Rows(r)) = 0 Then .Rows(r).Hidden = True Next r For c = 1 To .Columns.Count If Application.CountA(.Columns(c)) = 0 Then .Columns(c).Hidden = True Next c .Parent.PrintPreview .Cells.EntireRow.Hidden = False .Cells.EntireColumn.Hidden = False End With End Sub

I think that's enough for this question. You can review this link

Sub Test() Dim a, tmp, i As Long, ii As Long, t As Long a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value a(1, 3) = a(1, 2) & " 1" With CreateObject("Scripting.Dictionary") For i = 2 To UBound(a, 1) If Not .Exists(a(i, 1)) Then .Item(a(i, 1)) = Array(.Count + 2, 3) tmp = a(i, 2) a(.Count + 1, 1) = a(i, 1) a(.Count + 1, 2) = a(i, 3) a(.Count + 1, 3) = tmp Else t = .Item(a(i, 1))(1) + 1 If UBound(a, 2) < t Then ReDim Preserve a(1 To UBound(a, 1), 1 To t) a(1, t) = Replace(a(1, 3), "1", t - 2) End If a(.Item(a(i, 1))(0), t) = a(i, 2) .Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t) End If Next i t = .Count + 1 End With a(1, 2) = "Date" With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2)) .CurrentRegion.Clear .Value = a: .Borders.Weight = 2 .HorizontalAlignment = xlCenter .Columns.AutoFit .Parent.Select End With End Sub

Better to insert a column in the worksheet and populate the listbox from the column on the worksheet. Don't complicate your file

Here's the file You can click the button which has the caption [Click Here] or you can enter any value in column C in the first sheet to trigger the code GetUnique.xlsm

Attach a new file with some data and the new output

Public Sub CMDSEARCH_Click() Dim x, ws As Worksheet, i As Long, j As Long, lastRow As Long With Me.ListBox1 .Clear .ColumnCount = 7 .ColumnWidths = "60 pt;150 pt;80 pt;150 pt;100 pt;70 pt;100 pt" .ColumnHeads = 0 Set ws = Sheets("Ledger") x = Application.Match(ComboBox1.Value, ws.Rows(1), 0) If Not IsError(x) Then lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row For i = 1 To lastRow If TextBox1 <> "" And InStr(ws.Cells(i, x), TextBox1) <> 0 Then .AddItem .List(j, 0) = ws.Cells(i, 1) .List(j, 1) = ws.Cells(i, 3) .List(j, 2) = ws.Cells(i, 4) .List(j, 3) = ws.Cells(i, 16) .List(j, 4) = ws.Cells(i, 17) .List(j, 5) = ws.Cells(i, 18) .List(j, 6) = ws.Cells(i, 10) j = j + 1 End If Next i End If End With End Sub

I completely agree with Mr. Mohamed Just select is enough or you can use Application.GoTo Range("A1"), True

Sub Test() Dim a, x, ws As Worksheet, sh As Worksheet, r As Range Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) Set r = ws.Range("C2:C" & ws.Cells(Rows.Count, "C").End(xlUp).Row) a = Application.Transpose(r.Value) With Application x = .Index(a, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & UBound(.Match(a, a, 0)) & ")")), .Match(a, a, 0), 0), "|"), "|", False)) End With sh.Range("B2:B" & Rows.Count).ClearContents sh.Range("B2").Resize(UBound(x)).Value = Application.Transpose(x) End Sub

Sub Test() Dim r As Range Set r = Range("A1") r.Select SendKeys "{F2}", True DoEvents SendKeys "{LEFT " & CStr(Len(r.Value)) & "}", True DoEvents End Sub

Press Alt + F11 to open VBE editor > from Insert menu > Select Module > Paste the code I posted To run the code, press F5 when in VBE editor or go back to the worksheet and press Alt + F8 then select the macro name and finally click Run

Sub Test() Dim a, i As Long, ii As Long, t As Long a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 2).Value a(1, 2) = a(1, 2) & " 1" With CreateObject("Scripting.Dictionary") For i = 2 To UBound(a, 1) If Not .Exists(a(i, 1)) Then .Item(a(i, 1)) = Array(.Count + 2, 2) For ii = 1 To 2 a(.Count + 1, ii) = a(i, ii) Next ii Else t = .Item(a(i, 1))(1) + 1 If UBound(a, 2) < t Then ReDim Preserve a(1 To UBound(a, 1), 1 To t) a(1, t) = Replace(a(1, 2), "1", t - 1) End If a(.Item(a(i, 1))(0), t) = a(i, 2) .Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t) End If Next i t = .Count + 1 End With With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2)) .CurrentRegion.Clear .Value = a: .Borders.Weight = 2 .HorizontalAlignment = xlCenter .Columns.AutoFit .Parent.Select End With End Sub

Try this version for earlier versions of office Sub Test() Dim a, x, e, ws As Worksheet, sh As Worksheet, r As Range, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) With sh.Range("A4:N" & Rows.Count) .ClearContents: .Cells.UnMerge: .Borders.Value = 0 End With With ws.[A5].CurrentRegion Set r = .Offset(, .Columns.Count + 2).Range("A1:A2") a = Application.Transpose(.Columns(5).Offset(1).Value) With Application x = .Index(a, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & UBound(.Match(a, a, 0)) & ")")), .Match(a, a, 0), 0), "|"), "|", False)) End With For Each e In x If e <> "" Then r(2).Formula = "=E6=""" & e & """" m = sh.Cells(Rows.Count, 1).End(xlUp)(3).Row m = IIf(m <= 5, 4, m) With sh.Range("A" & m) .Value = e .Resize(1, 14).Merge .HorizontalAlignment = xlCenter End With .AdvancedFilter 2, r, sh.Range("A" & m + 1) End If Next e r.ClearContents End With Application.ScreenUpdating = True End Sub

Maybe the problem is with the UNIQUE function as it works on newer versions of excel only

Sheet1.Range("H" & Sheet1.Cells(Rows.Count, "H").End(xlUp).Row).PasteSpecial

Sub Test() Dim ws As Worksheet For Each ws In Worksheets ws.Visible = ws.Name = "Maine" Next ws End Sub

I could save to PDF without any problems in the PDF output. May be you have to change the virtual printer that you use

First correct the combobox name from [Calss] to [Class] In userform module Dim ws As Worksheet, m As Long Private Sub StudentName_Enter() Dim a, i As Long, k As Long If Natija.Value <> "" And Class <> "" Then a = ws.Range("A2:D" & m).Value ReDim b(1 To UBound(a, 1)) For i = LBound(a) To UBound(a) If Val(a(i, 3)) = Val(Class.Value) And a(i, 4) = Natija.Value Then k = k + 1 b(k) = a(i, 2) End If Next i If k > 0 Then ReDim Preserve b(1 To k): StudentName.List = b End If End Sub Private Sub UserForm_Initialize() Dim a Set ws = Worksheets("Sheet1") m = ws.Cells(Rows.Count, "B").End(xlUp).Row a = GetDistinct(ws.Range("D2:D" & m)) Natija.List = a a = GetDistinct(ws.Range("C2:C" & m)) Class.List = a End Sub Function GetDistinct(ByVal oTarget As Range) As Variant Dim vArr, v, dic As Object Set dic = CreateObject("Scripting.Dictionary") vArr = oTarget For Each v In vArr If Not IsEmpty(v) Then dic(v) = v Next v GetDistinct = dic.Items() End Function

May be attaching the file solves the problem Zodiac Signs.xlsm

After this line Cells(R + 6, "F").Value = .Cells(i, "H").Value Add this line Cells(R + 6, "G").Resize(1, 4).Value = .Cells(i, "I").Resize(1, 4).Value

Sub Test() Dim x, e, ws As Worksheet, sh As Worksheet, r As Range, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) With sh.Range("A4:N" & Rows.Count) .ClearContents: .Cells.UnMerge: .Borders.Value = 0 End With With ws.[A5].CurrentRegion Set r = .Offset(, .Columns.Count + 2).Range("A1:A2") x = .Parent.Evaluate("TRANSPOSE(UNIQUE(" & .Columns(5).Offset(1).Address & "))") For Each e In x If e <> "" Then r(2).Formula = "=E6=""" & e & """" m = sh.Cells(Rows.Count, 1).End(xlUp)(3).Row m = IIf(m <= 5, 4, m) With sh.Range("A" & m) .Value = e .Resize(1, 14).Merge .HorizontalAlignment = xlCenter End With .AdvancedFilter 2, r, sh.Range("A" & m + 1) End If Next e r.ClearContents End With Application.ScreenUpdating = True End Sub

There are no events for the check boxes on form controls, but there is a workaround In standard module put the code Sub CheckBoxFormControl() Dim ws As Worksheet, cb As Shape, sChk As String, r As Long, c As Long Set ws = ActiveSheet With ws.CheckBoxes(Application.Caller) sChk = .Name r = .TopLeftCell.Row c = .TopLeftCell.Column End With If ws.CheckBoxes(Application.Caller).Value = 1 Then For Each cb In ws.Shapes If cb.Type = msoFormControl Then If cb.FormControlType = xlCheckBox And cb.Name <> sChk Then If cb.TopLeftCell.Row = r And cb.TopLeftCell.Column = c Then If cb.ControlFormat.Value = 1 Then cb.ControlFormat.Value = -4146 End If End If End If Next cb End If End Sub Now select only one check box then press Ctrl + A to select all the check boxes on the worksheet then right click and assign macro [CheckBoxFormControl] The code will loop through each check box in the same row only and uncheck any other check boxes except the one triggered by Application.Caller

Th example you posted is the same result when I entered the day 16 in the inputbox Can you explain what's the wrong exactly

Sub Test() Dim Command_Buttons, ws As Worksheet, Prompt As String, Title As String, Project As Integer Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ws = ActiveWorkbook.Worksheets("Master") Prompt = "Sort Will Take Some Time. Please Wait" Command_Buttons = vbYesNo + vbMsgBoxRtlReading Title = "Do You Want To Sort After The Recent Changes?" Project = MsgBox(Prompt, Command_Buttons, Title) If Project = vbYes Then With ws.Sort .SortFields.Clear .SortFields.Add Key:=Range("BV8"), Order:=xlAscending .SortFields.Add Key:=Range("BT8"), Order:=xlDescending .SortFields.Add Key:=Range("C8"), Order:=xlAscending .SetRange Range("B8:BW6053") .Header = xlYes .Apply End With End If Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Call MsgBox("Sort Done", , "Thanks Allah") End Sub

Private Sub Workbook_Open() If Hex(CreateObject("Scripting.FileSystemObject").Drives.Item("D:").SerialNumber) <> "F8BCE74D" Then MsgBox "Message 1" ThisWorkbook.Close True End If If Date >= DateValue("12/12/2021") Or Sheets("Sheet2").Range("A48") = "mosaad" Then MsgBox "Expired", vbExclamation If InputBox("Enter Password") <> "123" Then Sheets("Sheet2").Range("A48") = "AA" MsgBox " Message 2 " ThisWorkbook.Save Application.Quit End If End If End Sub