VBA Macros

[christopherobin]

Hello,

Here is my problem.

I had someone help me create a macro in excel and it used to work perfectly. Now for some reason it does not.

Basically I want to enter names in excel and then transpose the data so I can enter in to ty contact manager.

The bizarre thing is the macro works in the old file yet when I post new entries it transposes everything but the email address.

The web page where I copy the information and then paste has changed slightly

-----

Here is the vba macro
------------------------------

Dim rwIndex As Long
Dim colIndex As Long
Dim NamePrinted As Boolean
Dim NewrowNbr As Long
Dim NewSet As Boolean
Dim RowCount As Long
Dim strData As String
Dim strTestCell As String
Dim ColumnToLoad As Integer

Application.ScreenUpdating = False

' Insert Headings
Worksheets("Sheet2").Activate
Worksheets("Sheet2").Range("A:G").Clear
Range("A1").Value = "Name"
Range("B1").Value = "Company"
Range("C1").Value = "E-mail"
Range("D1").Value = "Work Phone"
Range("E1").Value = "Fax"
Range("F1").Value = "Chapter"
Range("G1").Value = "Title"

With Range("A1:G1")
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With

NewrowNbr = 1
rwIndex = 1
'Get the number of rows used
Worksheets("Sheet1").Activate
RowCount = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

' loop thru all the data rows
Do Until rwIndex >= RowCount

' use the do statement to load columns 2 thru 9 (B thru I)
strTestCell = Cells(rwIndex, 1).Value
ColumnToLoad = 0
strData = Cells(rwIndex, 2).Value

Select Case strTestCell
' Blank line
Case ""
NewSet = True
NamePrinted = False

' Company
Case "Company:"
ColumnToLoad = 2

' E-mail:
Case "E-mail:"
If strData <> "" Then
strData = Cells(rwIndex, 2).Hyperlinks(1).Address()
strData = Right(strData, Len(strData) - 7)
End If
ColumnToLoad = 3

' Work Phone:
Case "Work Phone:"
ColumnToLoad = 4

' Fax:
Case "Fax:"
ColumnToLoad = 5

' Chapter:
Case "Chapter:"
ColumnToLoad = 6

' Title:
Case "Title:"
ColumnToLoad = 7

' Name
Case Else
If NamePrinted = False Then
If rwIndex = 1 Or NewSet = True Then
NewrowNbr = NewrowNbr + 1 'move to the next new data row
ColumnToLoad = 1
strData = strTestCell
NewSet = False
NamePrinted = True
End If
End If
End Select

If ColumnToLoad > 0 Then
Worksheets("Sheet2").Cells(NewrowNbr, ColumnToLoad).Value = strData
End If

rwIndex = rwIndex + 1 'read the next row of data
Loop

Application.ScreenUpdating = True

Worksheets("Sheet2").Activate
Columns("A:G").Select
Selection.Columns.AutoFit
Range("A1").Select

End Sub

 

[shajueasow]

The web page where I copy the information and then paste has changed slightly

How?
The code checks for E mail (address) in Column C and does the job if the corresponding cell is populated, ie, not a blank one. But now if the column in which you are entering e mail have changed, then it has to be coded accordingly

 

[christopherobin]

Emal in same place

The email is in the same place yet for some reason will not paste..