lionheart

Run the macro called "Test". The macro will save a text file copy of the file as you wish exactly and in the same path as in your code. Please try the code first before you post a reply.

Sub Test() Dim sName As String sName = Cells.Text & "D:\" & Cells(1, 2).Text & " Copy" & Format(Now, "-dddd-dd-mm-yyyy-") SaveWorkbookAs ThisWorkbook, sName, xlTextWindows End Sub Public Function SaveWorkbookAs(pWorkbook As Workbook, pFileName As String, pFileFormat As XlFileFormat) As Boolean Dim wFSO As Scripting.FileSystemObject, wWorkbook As Workbook, wScreenUpdating As Boolean, wEnableEvents As Boolean, wDisplayAlerts As Boolean, wTempName As String On Error Resume Next SaveWorkbookAs = False Set wFSO = New Scripting.FileSystemObject If pWorkbook Is Nothing Then GoTo EndFunction If (pFileName = vbNullString) Then GoTo EndFunction If (pWorkbook.FileFormat = pFileFormat) Then Err.Clear pWorkbook.SaveCopyAs pFileName SaveWorkbookAs = (Err.Number = 0) GoTo EndFunction End If With Application wScreenUpdating = .ScreenUpdating: .ScreenUpdating = False wEnableEvents = .EnableEvents: .EnableEvents = False wDisplayAlerts = .DisplayAlerts: .DisplayAlerts = False End With Err.Clear wTempName = wFSO.GetTempName pWorkbook.SaveCopyAs wTempName If (Err.Number > 0) Then GoTo EndFunction Err.Clear Set wWorkbook = Application.Workbooks.Open(wTempName, xlUpdateLinksNever) If (Err.Number > 0) Then GoTo EndFunction wWorkbook.SaveAs Filename:=pFileName, FileFormat:=pFileFormat SaveWorkbookAs = (Err.Number = 0) wWorkbook.Close SaveChanges:=False EndFunction: If (VBA.LenB(wTempName) > 0) Then If wFSO.FileExists(wTempName) Then wFSO.DeleteFile wTempName, True With Application .ScreenUpdating = wScreenUpdating .EnableEvents = wEnableEvents .DisplayAlerts = wDisplayAlerts End With Set wWorkbook = Nothing: Set wFSO = Nothing End Function From Tools > References: Microsoft Scriting Runtime

Sub Test() Dim r As Range, i As Long, c As Long Application.ScreenUpdating = False With CreateObject("VBScript.RegExp") .Global = True .Pattern = "\d+[.]\d+" For Each r In Range("C2", Range("C" & Rows.Count).End(xlUp)) c = 4 If .Test(r.Value) Then For i = 0 To .Execute(r.Value).Count - 1 Cells(r.Row, c).Value = .Execute(r.Value)(i) c = c + 1 Next i End If Next r End With Application.ScreenUpdating = True End Sub

Just format the cells of results to from the icon (Left-to-Right Text Direction) and make it (Right-to-Left)

If arr(i, 5) > 0 Then coll(s).Add CStr(arr(i, 2)) This line the number 5 refers to column E and the number 2 refers to column B

Sub Test() Dim r As Long Application.ScreenUpdating = False For r = 5 To Cells(Rows.Count, 3).End(xlUp).Row Cells(r, 37).Value = JoinIf("-", Range("F4:AJ4"), Range("F" & r & ":AJ" & r)) Next r Application.ScreenUpdating = True End Sub Function JoinIf(del As String, rngJoin As Range, rngCrit As Range) As String Dim c As Range, n As Long For Each c In rngCrit n = n + 1 If c <> Empty And rngJoin.Cells(n) <> "" Then JoinIf = JoinIf & del & Day(rngJoin.Cells(n)) Next c JoinIf = "'" & Mid(JoinIf, Len(del) + 1, Len(JoinIf)) End Function

Sub Test() Dim arr, v1, v2, coll As New Collection, s As String, max As Long, i As Long, j As Long Application.ScreenUpdating = False arr = Sheets("MP1").Range("A1").CurrentRegion.Value For i = 1 To UBound(arr, 1) s = CStr(arr(i, 1)) On Error Resume Next coll.Add Key:=s, Item:=New Collection On Error GoTo 0 If coll(s).Count = 0 Then coll(s).Add s If arr(i, 5) > 0 Then coll(s).Add CStr(arr(i, 2)) Next i For Each v1 In coll If v1.Count > max Then max = v1.Count Next v1 ReDim arr(1 To coll.Count, 1 To max) i = 0 For Each v1 In coll i = i + 1 j = 0 For Each v2 In v1 j = j + 1 arr(i, j) = v2 Next v2 Next v1 For j = 2 To max arr(1, j) = j - 1 Next j With Sheets("Result").Range("A1") .CurrentRegion.Clear .Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr With .CurrentRegion .EntireColumn.AutoFit .Borders.Value = 1 End With End With Application.ScreenUpdating = True End Sub Create a worksheet and name it "Result" first before running the code

="<>" & Range("E5").Value

So simple Criteria1:="<>WATE"

In worksheet module put the code Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C5:CJ5")) Is Nothing Then Application.EnableEvents = False If Target.Cells.CountLarge > 1 Then Target(1).Select Application.EnableEvents = True End If End Sub

You can't use formulas to move rows or delete rows and the code is very simple and it is basic

Sub Test() Dim ws As Worksheet, lr As Long, r As Long, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) m = 1 With Worksheets(1) lr = .Cells(Rows.Count, 1).End(xlUp).Row With .Range("B1:B" & lr) .Formula = "=COUNTIF($A$1:A1,A1)" .Value = .Value End With For r = lr To 1 Step -1 If .Cells(r, 2).Value > 1 Then ws.Cells(m, 1).Value = .Cells(r, 1).Value m = m + 1 .Rows(r).Delete End If Next r .Columns(2).ClearContents End With If m = 1 Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If Application.ScreenUpdating = True If m > 1 Then MsgBox "Names Moved = " & m - 1, 64 Else MsgBox "No Change", 64 End Sub

Easier to modify the last row numbers in your formulas but if you need a code to get only values you can try the following code in worksheet module Private Sub Worksheet_Change(ByVal Target As Range) Dim lr As Long If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Row > 1 And (Target.Column >= 1 And Target.Column <= 6) Then If Application.CountA(Range("A" & Target.Row).Resize(, 6)) = 6 Then With Sheet1 lr = .Cells(Rows.Count, 1).End(xlUp).Row Sheet2.Range("A2").Value = Application.Count(.Range("A2:A" & lr)) Sheet2.Range("B2").Value = Application.CountIf(.Range("C2:C" & lr), Sheet2.Range("B1").Value) Sheet2.Range("C2").Value = Application.CountIf(.Range("C2:C" & lr), Sheet2.Range("C1").Value) Sheet2.Range("D2").Value = Application.Sum(.Range("F2:F" & lr)) End With End If End If End Sub

Maybe you can store the desired ranges to delete into one variable using union then at last delete the rows in one shot

Please be precise when posting a question as the rgb values should be 225 not 255 Sub Test() Dim r As Long, m As Long, cnt As Long Application.ScreenUpdating = False m = Cells(Rows.Count, 1).End(xlUp).Row For r = m To 2 Step -1 If Cells(r, 1).Interior.Color = RGB(225, 225, 225) Or Cells(r, 1).Interior.Color = RGB(192, 192, 192) Or (Cells(r, 1).Value = "" And Cells(r, 2).Value = "") Then Cells(r, 1).Resize(1, 2).Delete Shift:=xlUp cnt = cnt + 1 End If Next r Application.ScreenUpdating = True MsgBox "There Are " & cnt & " Rows Deleted", 64 End Sub

Try to make a cell like M1 non-empty and modify the code Private Sub Worksheet_SelectionChange(ByVal M2 As Range) If Range("M1").Value = "" Then ActiveSheet.Cells.Interior.ColorIndex = 0 M2.EntireRow.Interior.ColorIndex = 6 End If End Sub

Post the code in worksheet module. Right-click the sheet name then select View Code then paste the code

I don't think it is working on this version. I am not sure

Use your office version 2016 then finally save the file with any older extension such as xls

Private Sub Worksheet_Change(ByVal Target As Range) Dim sCompany As String, m As Long If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Address = "$D$5" Then sCompany = Target.Value If Evaluate("ISREF('" & sCompany & "'!A1)") Then With Sheets(sCompany) m = .Cells(Rows.Count, "D").End(xlUp).Row + 1 .Range("D" & m).Resize(1, 4).Value = Application.Transpose(Range("M7:M10").Value) MsgBox "Data Copied To [ " & .Name & " ] Worksheet", 64 End With End If End If End Sub

We are in 2021 and you are still using 2007. I advise you to upgrade to 2019 or office 365

Private Sub ComboBox1_Change() Const iCols As Integer = 11 Dim a(1 To 1000, 1 To iCols), b(), rng As Range, c As Range, i As Long, ii As Long With Sheets(1) Set rng = .Range("B3:M" & .Cells(Rows.Count, "B").End(xlUp).Row) rng.AutoFilter Field:=12, Criteria1:=ComboBox1.Value On Error Resume Next Set rng = .Range("B3").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible) On Error GoTo 0 End With If Not rng Is Nothing Then For Each c In rng i = i + 1 For ii = LBound(a, 2) To UBound(a, 2) a(i, ii) = c.Offset(, ii - 1).Value Next ii Next c b = Application.Transpose(a) i = Application.Min(UBound(a, 1), i) ReDim Preserve b(1 To iCols, 1 To i) b = Application.Transpose(b) ListBox1.List = b End If End Sub

So simple. Do it yourself Create a variable and name it for example counter Then inside the loop and before the line that populates the value "Total" increase the variable by one like that counter = counter + 1 And finally put the ampersand symbol after the word "Total" and the variable name which is counter. That's all

Rename the data sheet to Data and create another sheet and name it Result OR change the sheet names in the code Sub Test() Const lRows As Long = 20, lCols As Long = 13 Dim ws As Worksheet, sh As Worksheet, rHeaders As Range, r As Long, lr As Long, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("Data") Set sh = ThisWorkbook.Worksheets("Result") sh.Cells.Clear Set rHeaders = ws.Range("A1:M1") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row For r = 2 To lr Step lRows m = sh.Cells(Rows.Count, "H").End(xlUp).Row + 1 m = IIf(m = 2, 1, m) rHeaders.Copy sh.Range("A" & m) With sh.Range("I" & m) .Interior.Color = vbYellow .Offset(, 2).Interior.Color = vbYellow End With ws.Range("A" & r).Resize(lRows, lCols).Copy sh.Range("A" & m + 1) With sh.Range("H" & m + lRows + 1) .Value = "Total": .Font.Bold = True .Offset(, 1).Formula = "=SUM(R[-1]C:R[-" & lRows & "]C)" .Offset(, 3).Formula = "=SUM(R[-1]C:R[-" & lRows & "]C)" .Resize(1, 4).Interior.Color = vbYellow End With Next r With sh.Cells .FormatConditions.Delete: .ReadingOrder = xlRTL .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .RowHeight = 23 .Columns(9).ColumnWidth = 10 .Columns(11).ColumnWidth = 14 .Font.Size = 14: .Font.Name = "Arial" End With Application.CutCopyMode = False On Error Resume Next sh.Range("I" & m & ":I" & m + lRows + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete On Error GoTo 0 sh.Range("A1").CurrentRegion.Borders.Value = 1 Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

Look my bro. You have wasted my time, I have told you that you have to comment out two specific lines and you didn't do that. Then I have modified the code for you and expected from you to copy the new code but it seems you didn't do that Please back to the code and copy it again to your file and test the code for last time.