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:
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
Where is the problem?
See below the file what I want to get.