lionheart

Sub Test() Dim x, r As Long, i As Integer, ii As Integer Application.ScreenUpdating = False For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row x = Split(Application.Trim(Cells(r, 2).Value)) ii = 0 For i = LBound(x) To UBound(x) If x(i) <> "" Then Cells(r, 3 + ii).Value = Val(x(i)): ii = ii + 1 Next i x = Split(Cells(r, 5).Value, Space(2)) ii = 0 For i = LBound(x) To UBound(x) If x(i) <> "" Then Cells(r, 6 + ii).Value = Trim(x(i)): ii = ii + 1 Next i Next r 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)

I will not waste more time with this issue. Wait for others for help

i didn't get what you mean exactly The code I posted is doing the same task as your code but keep the original workbook open. Please copy the code and insert it to a new module then go back to the worksheet then press Alt + F8 and run the code called "Test" and finally go to the partition d to see the text file output

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