Option Base 1
Sub TransferData()
'MrExcel forum name = Simple one: 2 Columns A & B I'll appreciate help
'https://www.mrexcel.com/forum/excel-questions/1085760-simple-one-2-columns-b-ill-appreciate-help.html
Application.ScreenUpdating = False
Sheets.Add.Name = "Sheet2" 'Create sheet2
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
ws2.Move after:=Worksheets(Worksheets.Count)
Dim Sheet1Array As Variant 'Array containing original data
Dim Sheet2Array As Variant 'Array containing only email addresses
Dim Sheet1ArrayR As Long 'Row number of Sheet1
Dim LoopNamesArrayR As Long 'Row Loop counter for Sheet1Array
Dim Sheet2ArrayR As Long 'Row number of Sheet2
Dim LenNum As Long 'Number of characters in eMail address
Dim Sheet1DataR As Long 'Loop counter = number of rows of data on Sheet1
Sheet1DataR = 1
LoopNamesArrayR = 0
Sheet2ArrayR = 0
With ws1
Sheet1ArrayR = .Cells(Rows.Count, "A").End(xlUp).Row - 1
ReDim Sheet2Array(Sheet1ArrayR, 2)
Set Sheet1Array = .Range("A2", .Range("A2").End(xlDown).End(xlToRight))
For Sheet1DataR = 1 To Sheet1ArrayR
LoopNamesArrayR = LoopNamesArrayR + 1
For LenNum = 1 To Len(Sheet1Array(LoopNamesArrayR, 2)) 'Loop checking whether '@' exists
If Mid(Sheet1Array(1, 2), LenNum, 1) = "@" Then 'If @ exists then add to Sheet2Array
Sheet2ArrayR = Sheet2ArrayR + 1
Sheet2Array(Sheet2ArrayR, 1) = Sheet1Array(LoopNamesArrayR, 1)
Sheet2Array(Sheet2ArrayR, 2) = Sheet1Array(LoopNamesArrayR, 2)
End If
Next LenNum 'Applies to For LenNum = 1 To Len(Sheet1Array(LoopNamesArrayR, 2))
Next Sheet1DataR 'Applies to For X = 1 to Sheet1Arrayr
End With
With ws2
ws2.Activate
.Range("A1:B1").Value = ws1.Range("A1:B1").Value 'Place column headings on sheet 2
.Range("A2").Resize(UBound(Sheet2Array, 1), UBound(Sheet2Array, 2)) = Sheet2Array
End With
Sheets(2).Columns.AutoFit 'Set column width to fit data
Application.ScreenUpdating = True
End Sub
