Find Copy and Paste

Hello friends,

Is it possible to get the numbers 13 characters long starting from 260 in the contents of cells A1: D10000? For example: On cell A1: 2601234567890 On cell A10: Excel xxxxx 2601234567890 D15 Cell: Trial xxxx 2601234567890 Excel xxxxx

Thank you, easy.

Contributor Asked on April 19, 2018 in VBA: Macros.
Add Comment
3 Answer(s)

For this to work please add custom format to format cells. Add 13 zeros as the custom format. See pictures. RT click on any cell.

RE: Find Copy and Paste

.

RE: Find Copy and Paste

.

The results of the macro are in column “F”

Sub GetTwoSixty()

Application.ScreenUpdating = False

Dim ws1 As Worksheet

Set ws1 = Worksheets("Sheet1")
Dim lRow As Long

lRow = ws1.UsedRange.Rows.Count
Dim i As Integer
On Error GoTo Line1

Columns("F:F").ClearContents

Application.DisplayAlerts = True

ThisWorkbook.Sheets.Add(After:= _

ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) _

.Name = "Temp"
ws1.Range("A1:D" & lRow).Copy Destination:=Worksheets("Temp").[A1]

[f1].Select

ActiveCell.Formula = "=right(A1,13)"

ActiveCell.Copy

For i = 1 To 3

ActiveCell.Offset(0, 1).PasteSpecial
Next i

[f1].Select

lRow = lRow - 1

ActiveCell.Offset(lRow).Select
For i = 1 To 4

Range(ActiveCell, ActiveCell.End(xlUp)).FillDown

ActiveCell.Offset(0, 1).Select

Next i
Range("F1").Select

ActiveCell.CurrentRegion.Select

Selection.Copy

Range("K1").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _

:=False, Transpose:=False

Columns("K:N").Select

Application.CutCopyMode = False

Selection.NumberFormat = "0000000000000"
lRow = ws1.UsedRange.Rows.Count

Range("L1:L" & lRow).Copy Destination:=Cells(Rows.Count, 11).End(xlUp).Offset(1)

Range("M1:M" & lRow).Copy Destination:=Cells(Rows.Count, 11).End(xlUp).Offset(1)

Range("N1:N" & lRow).Copy Destination:=Cells(Rows.Count, 11).End(xlUp).Offset(1)
Columns("K:K").Select

ActiveWorkbook.Worksheets("Temp").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Temp").Sort.SortFields.Add Key:=Range("K1:K100000"), _

SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("Temp").Sort

.SetRange Range("K1:K100000")

.Header = xlGuess

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Columns("L:N").ClearContents

[L1].Formula = "=Left(K1,3)"

Range("K1").End(xlDown).Offset(0, 1).Select

Range(ActiveCell, ActiveCell.End(xlUp)).FillDown
[L1].Select
Do Until IsEmpty(ActiveCell)

If ActiveCell.Value = 260 Then

ActiveCell.Offset(1).Select

Else

Rows(ActiveCell.Row).EntireRow.Delete

End If

Loop

Columns("L:L").ClearContents

[K1].Select

ActiveCell.CurrentRegion.Copy Destination:=ws1.Range("F1")

ws1.Activate
Application.DisplayAlerts = False

ThisWorkbook.Sheets("Temp").Delete

Line1:
End Sub

Expert Answered on April 19, 2018.
Add Comment

Oh sorry forgot the before and after pictures, Here they are.

RE: Find Copy and Paste

 

Expert Answered on April 19, 2018.
Add Comment

Thanks Hyside2, Will try out and get back to you.

Regards

Ozuberk

Contributor Answered on April 25, 2018.
Add Comment
  • Found this useful?

    Please share using the share button above.

    If you found the answer is best answer for your question, Please mark as 'best answer' by clicking on the right tick mark icon at the left side of the answer.

    Found the answer useful and wants to credit the user, then vote the answer (vote up).

  • Your Answer

    By posting your answer, you agree to the privacy policy and terms of service.