lionheart

It seems you didn't try my code well. Have a look at this line of code If c = 3 Then .Text = .Text Else .Value = .Value

Option Explicit Private Sub CommandButton1_Click() Dim ws As Worksheet, i As Long, k As Long For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.Selected(i) Then k = k + 1 Set ws = Worksheets(Me.ListBox1.List(i, 0)) ws.Move Before:=ThisWorkbook.Worksheets(k) End If Next i End Sub Private Sub UserForm_Activate() Dim ws As Worksheet With Me.ListBox1 .Clear For Each ws In Worksheets .AddItem ws.Name Next ws End With End Sub

Sub Test() Dim rng As Range, c As Long Application.ScreenUpdating = False Set rng = Range("A5:J" & Cells(Rows.Count, "D").End(xlUp).Row) rng.UnMerge For c = 1 To rng.Columns.Count With rng.Columns(c) On Error Resume Next .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C" If c = 3 Then .Text = .Text Else .Value = .Value On Error GoTo 0 End With Next c Application.ScreenUpdating = True End Sub

Sub Test() GenerateUniqueRandom ActiveSheet, "D3:F22", 1, 60 End Sub Sub GenerateUniqueRandom(ByVal shTarget As Worksheet, ByVal sRng As String, ByVal iStart As Long, iEnd As Long) Dim w, v, rng As Range, c As Range, n As Long, i As Long, ii As Long, r As Long Set rng = shTarget.Range(sRng) If iEnd - iStart + 1 > rng.Cells.Count Then MsgBox "Generated Numbers Greater Than Range Cell Count", vbExclamation: Exit Sub w = Evaluate("ROW(" & iStart & ":" & iEnd & ")") n = 0 ReDim v(1 To rng.Rows.Count, 1 To rng.Columns.Count) For i = LBound(v, 1) To UBound(v, 1) For ii = LBound(v, 2) To UBound(v, 2) r = Application.RandBetween(iStart, UBound(w) - n) v(i, ii) = w(r, 1) w(r, 1) = w(UBound(w) - n, 1) n = n + 1 Next ii Next i rng.Cells(1).Resize(UBound(v, 1), UBound(v, 2)).Value = v End Sub

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