Attribute VB_Name = "Module1"
Sub ExtractName()
   'Establish database connection
   Dim Conn As New ADODB.Connection
   Dim Rs As New ADODB.Recordset
   Conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=eC_recipient.mdb"
   Conn.Open
   With Rs
       .CursorType = adOpenStatic
       .CursorLocation = adUseServer
       .LockType = adLockReadOnly
       .ActiveConnection = Conn
       .Open "SELECT * FROM eC_recipient", , , , adCmdText
   End With
   'Initialize workbook variable
   Dim SourceCol As Range
   Dim ScolCount, colCounter As Long
   On Error Resume Next
   'Preparing a new worksheet for data dumping
   Application.DisplayAlerts = False
   ActiveWorkbook.Worksheets("Results").Delete
   Application.DisplayAlerts = True
   DeleteWorksheet = Not CBool(Err.Number)
   'Count total numbers of worksheet
   Dim i, count As Integer
   Dim lastname As String
   For i = 1 To ActiveWorkbook.Worksheets.count
       count = count + 1
   Next
   lastname = ActiveWorkbook.Worksheets.Item(count).Name
'    MsgBox CStr(count)
   Dim wksNewSheet As Excel.Worksheet
   Set wksNewSheet = Worksheets.Add
   'Name and allocate the new worksheet
   With wksNewSheet
       .Name = "Results"
       .Move After:=Worksheets(lastname)
   End With
   'Make a count of how many cells have to process
   Worksheets(1).Activate
   Set SourceCol = Columns("A")
   For colCounter = 1 To SourceCol.Rows.count
       ScolCount = ScolCount + 1
   Next
'    MsgBox CStr(ScolCount)
   'Start processing
   Dim tempC, tempStr As String
   For i = 1 To ScolCount
       Set curcell = Worksheets("Results").Cells(i, 1)
       Set curcell2 = Worksheets("Results").Cells(i, 2)
       If SourceCol.Cells(i).Value <> "" Then
           tempC = UCase(Replace(SourceCol.Cells(i).Value, Mid(SourceCol.Cells(i).Value, 1, 33), ""))
           Rs.MoveFirst
           Do While Not Rs.EOF
               tempStr = UCase(Replace(Rs.Fields(0).Value, Mid(Rs.Fields(0).Value, 1, 6), ""))
               If tempC = tempStr Then
                   curcell.Value = tempC
                   curcell2.Value = Rs.Fields(1).Value
                   GoTo Exit_Loop
               End If
               Rs.MoveNext
           Loop
           curcell.Value = tempC
           curcell2.Value = "Unknown"
       End If
Exit_Loop:
   Next
   If Err.Number <> 0 Then
       MsgBox Err.Number + " " + Err.Description + " " + Err.Source
   End If
   MsgBox CStr(ScolCount) + " records completed!", vbInformation + vbOKOnly, "Completed!"
   Worksheets("Results").Activate
   Columns("A:A").EntireColumn.AutoFit
   Columns("B:B").EntireColumn.AutoFit
End Sub

0 comments: