Hello everybody.
I am struggling with the solution to copy out specific cells sequentially through the cells from 2 columns, but still no luck to complete it. Currently it do nothing.
The format that I want:
Code
Sub test()
Dim ws, ws2 As Worksheet, v As Variant, k As Long, i
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
Sheets("NewSheet").Delete
k = 1
Sheets.Add.Name = "NewSheet"
Set ws = Worksheets("Details for we 200522")
Set ws2 = Worksheets("NewSheet")
ws.Activate
For Each xcell In Intersect(Range("B:B"), ws.UsedRange)
'Check if certain selected cell through loop starts with "33". If yes (>0) then copy this cell to ws2 in k row
i = xcell.Value
If InStr(i, Left(i, 2)) > 0 Then
i.Copy ws2.Cells(k, 1)
k = k + 1
'to keep the format continue to check A:A column to proceed information copying
For Each ycell In Intersect(Range("A:A"), ws.UsedRange)
'Check if certain selected cell through loop starts with "UK". If yes (>0) then copy entire row to ws2 in k row
j = ycell.Value
If InStr(j, Left(j, 2)) > 0 Then
i.Copy.EntireRow ws2.Cells(k, 1)
k = k + 1
End If
Next ycell
End If
Next xcell
'Delete unnecessary columns to make the needed format
ws2.Range(Cells(1, 2), Cells(1, 7)).EntireColumn.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Display More
Where is the problem?
See below the file what I want to get.