lionheart

Where do you put the code, in excel or access If in excel, press Alt + F11 to open VBE editor and insert Module from insert menu and paste the code First clear the contents from A2 to A and the last row before running the code I posted before

Attach your file please

Sub Test() Dim w w = Evaluate("ROW(1:" & Cells(Rows.Count, "B").End(xlUp).Row - 1 & ")") Range("A2").Resize(UBound(w, 1)).Value = w End Sub

Thank you very much every body for your encouragement

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