lionheart

Option Explicit Const iCol As Integer = 7 Sub Test() Dim e, rng As Range, lr As Long Const sOutput As String = "Output" 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) lr = .Cells(Rows.Count, 1).End(xlUp).Row .Range("A1").CurrentRegion.Borders.Value = 1 .Columns("A:F").AutoFit With .Columns("G") .ColumnWidth = 80 .Rows("1:" & lr).HorizontalAlignment = xlRight End With .Range("A1").Resize(, iCol).Interior.Color = RGB(255, 217, 102) With .Sort .SortFields.Clear For Each e In Array("A1", "B1", "C1", "D1", "E1") .SortFields.Add Key:=Range(e), Order:=xlAscending Next e .SetRange Range("A1:A" & lr).Resize(, iCol) .Header = xlYes .Apply End With Set rng = .Range("A2:A" & lr) MergeSimilarCells rng End With Application.ScreenUpdating = True End Sub Sub MergeSimilarCells(workRng As Range) Dim rng As Range, nRng As Range, xRows As Integer, i As Integer, j As Integer, ii As Integer, cnt As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False xRows = workRng.Rows.Count For Each rng In workRng.Columns For i = 1 To xRows - 1 For j = i + 1 To xRows If rng.Cells(i, 1).Value <> rng.Cells(j, 1).Value Then Exit For Next j Set nRng = workRng.Parent.Range(rng.Cells(i, 1), rng.Cells(j - 1, 1)) If nRng.Rows.Count > 1 Then For ii = 0 To 4 nRng.Offset(, ii).Resize(nRng.Rows.Count).Merge Next ii End If nRng.Resize(, iCol).BorderAround Weight:=xlThick nRng.Offset(, iCol - 1).Resize(nRng.Rows.Count).WrapText = True cnt = cnt + 1 If cnt Mod 2 = 0 Then nRng.Resize(, iCol).Interior.Color = RGB(255, 230, 152) Else nRng.Resize(, iCol).Interior.Color = RGB(255, 242, 204) End If i = j - 1 Next i Next rng Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

Sub Test() Dim ws As Worksheet, cl As Range, rng As Range, v As String Set ws = Sheets("Sheet1") With CreateObject("Scripting.Dictionary") For Each cl In ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp)) v = Join(Application.Index(cl.Resize(, 7).Value, 1, Array(1, 2, 3, 4, 5)), "|") If Not .Exists(v) Then .Add v, cl Else If rng Is Nothing Then Set rng = cl Else Set rng = Union(rng, cl) End If Next cl End With If Not rng Is Nothing Then rng.EntireRow.Delete End Sub

I work on just only one file. Try to study the code and modify it by yourself

The name in cell C10 should have a space between the first name and last name so as to be identical as the name in cell C5 Sub Test() Dim a, txt As String, i As Long, ii As Long a = Range("C5:G" & Cells(Rows.Count, "C").End(xlUp).Row).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) txt = a(i, 1) If Not .Exists(txt) Then .Item(txt) = .Count + 1 For ii = 1 To UBound(a, 2) a(.Count, ii) = a(i, ii) Next ii Else For ii = 2 To UBound(a, 2) a(.Item(txt), ii) = a(.Item(txt), ii) + a(i, ii) Next ii End If Next i i = .Count End With [J6].Resize(i, UBound(a, 2)) = a End Sub

Private Sub Worksheet_Activate() Dim e, ws As Worksheet For Each ws In ThisWorkbook.Worksheets If ws.Name <> Me.Name Then ws.Visible = xlSheetVeryHidden End If Next ws For Each e In Array("1", "2") Worksheets(e).Visible = xlSheetVisible Next e End Sub

Right-click worksheet name and select View Code and paste the code I posted Back to the worksheet, type any month number (say 10) in cell S2 and press Enter key

In worksheet module put the following code (but it is better to depend on another cell in the first two columns a way from S2) Private Sub Worksheet_Change(ByVal Target As Range) Dim myMonth, c As Long If Target.Address = "$S$2" Then Application.ScreenUpdating = False myMonth = Target.Value Columns("C:KX").Hidden = True For c = 3 To 310 With Cells(5, c) If .Value2 <> "" And Month(.Value2) = myMonth Then .EntireColumn.Hidden = False End If End With Next c Application.ScreenUpdating = True End If End Sub

So simple question. Just loop through the columns and check for the month of the date and hide those columns that don't have the same month

You are allowed to type yes or no only

How to execute code without code? and for what purpose you don't need to keep the code inside the file itself

The scroll button is linked to specific cell. Change the properties of that cell to make it unprotected Right-Click the cell and format cells and from Protection tab uncheck the option of Locked

The request is weird a little and using data validation list is better than using the code in worksheet module Generally here's the code (In Worksheet Module) Private Sub Worksheet_Change(ByVal Target As Range) Call Worksheet_SelectionChange(Target) End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) With Target If .Cells.CountLarge > 1 Then Exit Sub If .Row > 1 And .Column = 2 Then If LCase(.Value) = "yes" Or LCase(.Value) = "no" Then Application.EnableEvents = False .Value = StrConv(.Value, vbProperCase) .Font.ColorIndex = xlAutomatic Application.EnableEvents = True Exit Sub Else Application.EnableEvents = False .Value = Empty Application.EnableEvents = True End If If .Value = "" And .Offset(, -1).Value <> "" Then Application.EnableEvents = False .Value = "Type 'Yes' to accept - Type 'No' to reject" With .Font .Name = "Calibri" .FontStyle = "Regular" .Size = 9 .Color = RGB(217, 217, 217) End With Application.EnableEvents = True End If End If End With End Sub

Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, lc As Long, r As Long, c As Long, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) sh.Range("B7:C100").ClearContents lr = LastRow(ws) lc = LastCol(ws) m = 7 For r = 4 To lr Step 2 For c = 1 To lc If ws.Cells(r + 1, c).Value <> "" Then sh.Cells(m, 2).Value = ws.Cells(r, c).Value sh.Cells(m, 3).Value = ws.Cells(r + 1, c).Value m = m + 1 End If Next c Next r Application.ScreenUpdating = True MsgBox "Done", 64 End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row On Error GoTo 0 End Function Function LastCol(sh As Worksheet) On Error Resume Next LastCol = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column On Error GoTo 0 End Function

It seems links are forbidden here in this forum (and that is too weird) remove spaces in the following line https: // excel-egy . com / forum/ t2823

Here's a file with 3000 rows File.xlsm

Can you attach the file that has 3000 rows? It is supposed not so big number of rows

Try the code with large amount of data and tell us the final result and the time that will the code take

Just change the range in this line to suit your needs Range("A2", Range("A" & Rows.Count).End(xlUp))

Use IFERROR function

You are asking for a complete program not for a solution of a specific problem so I think you will not find any help Be specific and ask for the solution of only one problem and explain it well

To implement .. With your workbook active press Alt+F11 to bring up the vba window. In the Visual Basic window use the menu to Insert|Module Copy and Paste the code below into the main right hand pane that opens at step 2. Close the Visual Basic window. Press Alt+F8 to bring up the Macro dialog Select the macro & click ‘Run’ Your workbook will need to be saved as a macro-enabled workbook (*.xlsm) Don't forget to remove the conditional formatting from the worksheet

I think the link on excel-egy on this topic t2823 will be useful for you

You didn't explain the problem well. Please be sepcific and put the desired output as an image if you wait more help Private Sub btnOk_Click() Dim x As Control, s As String, r As Long Range("H1:H30").Clear For Each x In UserForm2.Controls If TypeName(x) = "CheckBox" Then If x.Value = True Then r = r + 1 s = s & IIf(s = vbNullString, vbNullString, vbLf) & x.Name Cells(r + 4, "H").Value = x.Caption End If End If Next x Range("H4").Value = r End Sub

I have no idea. Attach your file

Sub Test() Dim w, d As Object, r As Range Set d = CreateObject("Scripting.Dictionary") d.CompareMode = 1 With Range("A2", Range("A" & Rows.Count).End(xlUp)) .Interior.colorIndex = xlNone For Each r In .Cells If Not d.Exists(r.Value) Then ReDim w(1 To 2) Set w(1) = r With Application.WorksheetFunction w(2) = Array(.RandBetween(0, 255), .RandBetween(0, 255), .RandBetween(0, 255)) End With d(r.Value) = w Else w = d(r.Value) r.Interior.Color = RGB(w(2)(0), w(2)(1), w(2)(2)) If Not IsEmpty(d(r.Value)(1)) Then d(r.Value)(1).Interior.Color = RGB(w(2)(0), w(2)(1), w(2)(2)) w(1) = Empty d(r.Value) = w End If Next r End With End Sub