lionheart

How did you get those names Maybe you have to go back step backward to be able to solve this problem

In any worksheet module, put the following code Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Const sListBoxName As String = "Export Sheets" Dim ws As Worksheet, lst As ListBox, sPath As String, sFile As String, i As Long, c As Long If Target.Address = "$A$1" Then Cancel = True With Me Set lst = Nothing On Error Resume Next Set lst = .ListBoxes(sListBoxName) On Error GoTo 0 If lst Is Nothing Then Set lst = .ListBoxes.Add(.Range("F2").Left, .Range("F2").Top, 160, 84) End With With lst .Name = sListBoxName .RemoveAllItems .MultiSelect = xlSimple For Each ws In ActiveWorkbook.Sheets .AddItem ws.Name Next ws End With ElseIf Target.Address = "$B$1" Then Cancel = True Set lst = Me.ListBoxes(sListBoxName) With lst For i = 1 To .ListCount If .Selected(i) Then c = c + 1 sPath = ThisWorkbook.Path & "\" With ActiveWorkbook.Sheets(.List(i)) Application.ScreenUpdating = False Application.DisplayAlerts = False .Copy: sFile = .Name With Application.ActiveWorkbook .SaveAs Filename:=sPath & sFile & ".xlsx" .Close False End With Application.DisplayAlerts = True Application.ScreenUpdating = True End With End If Next i End With If c > 0 Then MsgBox "You Exported " & c & " Sheets Successfully", 64, "LionHeart" End If End Sub To use the code Double-click cell A1 and a listbox with the worksheets names will be created Select the sheet or sheets you want to export from the listbox Finally double-click cell B1 to export the sheets you selected from the listbox

Why do you want me to upload a file? Just copy the formula

In cell F2 put the formula =IFERROR(INDEX($A$1:$E$1,MATCH(E2,$A$2:$D$2,0)),"NOT SPECIFIC")

Sub Test_Timer() Dim i As Long, k As Long Range("B3").Value = 0 Do Until Range("B3").Value = 4 Range("B3").Value = Range("B3").Value + 1 For i = 5 To 1 Step -1 Application.ScreenUpdating = True Range("E3").Value = i DoEvents For k = 1 To 100000000 Next k Next i Application.Wait Now + TimeValue("00:00:01") Loop End Sub

Sub Test() Dim a, vArray(), sOut As String, i As Long, ii As Long, k As Long Application.ScreenUpdating = False a = Range("A2").CurrentRegion.Value ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 1) For i = LBound(a, 1) To UBound(a, 1) For ii = LBound(a, 2) To UBound(a, 2) k = k + 1 b(k, 1) = a(i, ii) Next ii Next i Columns("G").ClearContents Range("G2").Resize(UBound(b, 1), UBound(b, 2)).Value = b vArray = Application.Transpose(b) sOut = Join(vArray, vbCrLf) Open ThisWorkbook.Path & "\Output.txt" For Output As #1 Print #1, sOut Close #1 Application.ScreenUpdating = True MsgBox "Done...", 64, "LionHeart" End Sub

That's great you have tried that's a great step towards learning Sub Test() Dim m As Long, r As Long, n As Long Application.ScreenUpdating = False With ActiveSheet m = .Cells(Rows.Count, 1).End(xlUp).Row n = 1 .Columns("K:M").WrapText = True For r = 1 To m Step 3 .Range("K" & n).Resize(, 3).Value = Array(.Range("A" & r).Value & vbLf & .Range("A" & r + 1).Value & vbLf & .Range("A" & r + 2).Value, .Range("B" & r).Value & vbLf & .Range("B" & r + 1).Value & vbLf & .Range("B" & r + 2).Value, .Range("C" & r).Value & vbLf & .Range("C" & r + 1).Value & vbLf & .Range("C" & r + 2).Value) n = n + 1 Next r End With Application.ScreenUpdating = True End Sub

Try to get this line well .Range("K" & n).Resize(, 3).Value = Array(.Range("A" & r).Value & vbLf & .Range("A" & r + 1).Value, .Range("B" & r).Value & vbLf & .Range("B" & r + 1).Value, .Range("C" & r).Value & vbLf & .Range("C" & r + 1).Value) I didn't ask you to write a whole code, just understand the code to be able to modify it

Use your mind please. Study the code well Think of dealing with the three rows by changing the step from step 2 to step 3 and change the code according this

Sub Test() Dim m As Long, r As Long, n As Long Application.ScreenUpdating = False With ActiveSheet m = .Cells(Rows.Count, 1).End(xlUp).Row n = 1 .Columns("K:M").WrapText = True For r = 1 To m Step 2 .Range("K" & n).Resize(, 3).Value = Array(.Range("A" & r).Value & vbLf & .Range("A" & r + 1).Value, .Range("B" & r).Value & vbLf & .Range("B" & r + 1).Value, .Range("C" & r).Value & vbLf & .Range("C" & r + 1).Value) n = n + 1 Next r End With Application.ScreenUpdating = True End Sub

=IF(D18=11,(IO9),IF(D18=11.3,(IP9),IF(D18=11.7,(IQ9),IF(D18=12,(IR9),IF(D18=12.3,(IS9),IF(D18=12.7,(IT9),IF(D18=13,(IV9)," "))))))) PT.xlsx

Sub Test() Dim a, r As Long, i As Long Application.ScreenUpdating = False r = 2 For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row Step 3 a = Range("A" & i).Resize(3).Value Cells(r, "C").Resize(, UBound(a)).Value = Application.Transpose(a) r = r + 1 Next i Application.ScreenUpdating = True End Sub

It's better not to put a lot of codes in worksheet module such as worksheet_change. Just input your data and finally click on a button to do all the task for you in one shot

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) استخراج اسماء من اسم كامل.xlsm

Sub Test() Dim a, ws As Worksheet, rng As Range, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) m = ws.Cells(Rows.Count, "B").End(xlUp).Row Set rng = ws.Range("B3:B" & m) rng.Offset(, 1).Formula = "=kh_Names($B3,1,2)" rng.Offset(, 2).Formula = "=kh_Names($B3,1,2,3)" rng.Offset(, 3).Formula = "=kh_Names($B3,1,2,3,4)" rng.Offset(, 4).Formula = "=IF(COUNTIF($C$3:$C$" & m & ",C3)>1,COUNTIF($C$3:$C$" & m & ",C3),C3)" rng.Offset(, 5).Formula = "=IFERROR(IF(VALUE(F3)>1,IF(COUNTIF($D$3:$D$" & m & ",D3)>1,COUNTIF($D$3:$D$" & m & ",D3),D3),""""),"""")" rng.Offset(, 6).Formula = "=IFERROR(IF(VALUE(G3)>1,IF(COUNTIF($E$3:$E$" & m & ",E3)>1,COUNTIF($E$3:$E$" & m & ",E3),E3),""""),"""")" With rng.Offset(, 7) .Formula = "=CONCATENATE(IF(AND(ISTEXT(F3),F3<>""""),F3,""""),IF(AND(ISTEXT(G3),G3<>""""),G3,""""),IF(AND(ISTEXT(H3),H3<>""""),H3,""""))" a = .Value rng.Offset(, 1).Value = a End With ws.Columns("D:I").ClearContents Application.ScreenUpdating = True End Sub

Sub Test() Dim r As Long Application.ScreenUpdating = 0 For r = 5 To Cells(Rows.Count, "C").End(xlUp).Row If Cells(r, "C").Value <> "" Then If Cells(r, "F").Value <> "" And Cells(r, "G").Value = "" Then Cells(r, "G").Value = 0 End If If Cells(r, "F").Value = "" And Cells(r, "G").Value <> "" Then Cells(r, "F").Value = 0 End If End If Next r Application.ScreenUpdating = 1 End Sub

Try the same steps as we did with MSSTKPRP.DLL but with mscomctl.ocx mscomctl.zip Does the error message change or the same message exactly

Explain more details about the office version and the type of bit for the Office The same for your windows version and whether it is 32Bit or 64Bit Did you try to restart after the steps Try also installing this package Please restart your PC after installing the package If the problem is still there , record a video of the steps while you are applying the steps VisualBasic6-KB896559-v1-ENU.zip Another point, there is a button below each post that says "LIKE" if you like the posts

MSSTKPRP.zipThis is the DLL file

Close Excel application Download MSSTKPRP.zip file and extract the MSSTKPRP.DLL to these paths C:\Windows\System32 C:\Windows\SysWOW64 Open command prompt as administrator and type these commands cd C:\Windows\System32 regsvr32 MSSTKPRP.DLL cd C:\Windows\SysWOW64 regsvr32 MSSTKPRP.DLL You may need to restart your pc

In worksheet module Private Sub Worksheet_SelectionChange(ByVal Target As Range) Me.Unprotect If Target.Cells(1).Value = Empty Then Exit Sub Me.Protect End Sub

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