christopherobin
New Member
- Joined
- Aug 24, 2005
- Messages
- 2
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
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