When attempting to run macro Excel opens different workbook
Hi,
I've posted my code below. I have a toolbar that I created that runs two
functions contained in a module in an Excel 2002 workbook. When I ran the
procedures I did a 'save as' and renamed the current workbook and closed it.
I then reopened the original workbook and attempted to run the same two
procedures but for some reason everytime I attempt to run these Excel opens
the new 'saved as' version of the workbook and runs then runs the
procedures. Can anyone tell me why the other saved workbook is opening when
I run this code? The code is also in the newer saved version - I don't know
what this has to do with it though since the file is closed when I run the
code - any help would be appreciated. Also, this code worked fine when I ran
it from two command buttons but the problems began when I started running it
from a custom toolbar. I have to use a toolbar so buttons aren't an option
code:
Sub Openimportfile()
On Error GoTo import_err
fname = Application.GetOpenFilename(Title:="Select a File to Import",
MultiSelect:=False)
If fname < False Then
Set mybook = Workbooks.Open(Filename:=fname)
Set r = mybook.Worksheets(1).Columns("A").Cells
For Each c In r.Cells
'grab title
If Left(c.Value, 5) = "TI -" Then
strTitle = Trim(Right(c.Value, Len(c.Value) - 5))
Set nextCell = c.Offset(1, 0)
Do While Mid(nextCell.Value, 5, 1) < "-"
strTitle = strTitle & " " & Trim(nextCell.Value)
Set nextCell = nextCell.Offset(1, 0)
Loop
If Right(strTitle, 1) = "." Then strTitle = Left(strTitle,
Len(strTitle) - 1)
If strTitle = "" Then strTitle = "N/A"
Set rTitle = ThisWorkbook.Worksheets(1).Columns("A").Cells
For Each ctitle In rTitle.Cells
If ctitle.Value = "" Then
currRow = ctitle.Row
ctitle.Value = strTitle
Exit For
End If
Next
End If
'grab Address
If Left(c.Value, 5) = "AD -" Then
strAddress = Trim(Right(c.Value, Len(c.Value) - 5))
Set nextADCell = c.Offset(1, 0)
Do While Mid(nextADCell.Value, 5, 1) < "-"
strAddress = strAddress & " " & Trim(nextADCell.Value)
Set nextADCell = nextADCell.Offset(1, 0)
Loop
'grab email
lemail = InStr(strAddress, "@")
If lemail 0 Then
lemail = lemail - 1
For i = lemail To 1 Step -1
If Mid(strAddress, i, 1) = " " Then Exit For
strEmail = Right(strAddress, Len(strAddress) - (i -
1))
Next
strAddress = Left(strAddress, Len(strAddress) -
Len(strEmail))
End If
strRange = "B" & ctitle.Row
Set raddress = ThisWorkbook.Worksheets(1).Range(strRange)
raddress.Value = strAddress
strRange = "C" & ctitle.Row
Set rEmail = ThisWorkbook.Worksheets(1).Range(strRange)
rEmail.Value = strEmail
End If
'grab Name
If Left(c.Value, 5) = "FAU -" Then
Set prevCell = c.Offset(-1, 0)
If (Left(prevCell.Value, 5) < "FAU -" And Left(prevCell.Value,
5) < "AU -") Then
strname = Trim(Right(c.Value, Len(c.Value) - 5))
strFirstName = Right(strname, Len(strname) - InStr(strname,
","))
strLastName = Left(strname, InStr(strname, ",") - 1)
strRangeFirst = "D" & ctitle.Row
strRangeLast = "E" & ctitle.Row
Set rFirstName =
ThisWorkbook.Worksheets(1).Range(strRangeFirst)
Set rLastName =
ThisWorkbook.Worksheets(1).Range(strRangeLast)
rFirstName.Value = Trim(strFirstName)
rLastName.Value = Trim(strLastName)
End If
End If
'grab Journal
If Left(c.Value, 5) = "TA -" Then
strJournal = Trim(Right(c.Value, Len(c.Value) - 5))
strRange = "F" & ctitle.Row
Set rJournal = ThisWorkbook.Worksheets(1).Range(strRange)
rJournal.Value = strJournal
End If
strTitle = ""
strFirstName = ""
strLastName = ""
strAddress = ""
strEmail = ""
strJournal = ""
Next
mybook.Close
ActiveWorkbook.Save
MsgBox "Import Complete."
End If
Exit Sub
import_err:
MsgBox Err.Description
Exit Sub
End Sub
Public Sub ClearData()
On Error GoTo ClearData_err
Cells.Select
Selection.ClearContents
ThisWorkbook.Worksheets(1).Range("A1").Value = "Title"
ThisWorkbook.Worksheets(1).Range("B1").Value = "Address"
ThisWorkbook.Worksheets(1).Range("C1").Value = "Email"
ThisWorkbook.Worksheets(1).Range("D1").Value = "First Name"
ThisWorkbook.Worksheets(1).Range("E1").Value = "Last Name"
ThisWorkbook.Worksheets(1).Range("F1").Value = "Journal"
ActiveWorkbook.Save
Exit Sub
ClearData_err:
MsgBox Err.Description
Exit Sub
End Sub
|