Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.

Dismiss

Run-Time Error "9". Subscript out of range

4 views

Skip to first unread message

Kanmi

unread,

Jul 7, 2009, 10:12:02 AM7/7/09

I,m trying to use this code to automatic update two workbooks" source.xls"
get update from database and i want destination.xls pulled automatic update
to sheet name"WPS Detail Dates" on some rows. Please do i run this script in
source.xls or destination.xls and why is it showing this error. You will be
more than welcome to put in your opinion. Thanks and Appreciate your time.
------------------------------------------------------------
Sub CreateMaster()

Set Source = Workbooks("Source.xls")
Set SourceSht = Source.Sheets("Sheet1")
'Set SourceSht = Sheets("Sheet1")

Set Dest = Workbooks("Destination.xls")
'Set Dest = ThisWorkbook
'create new worksheet
With Dest
Set DestSht = .Sheets.Add(after:=.Sheets(.Sheets.Count))
DestSht.Name = "Master"
End With

With DestSht

SourceSht.Columns("C:C").Copy _
Destination:=.Columns("C:C")
Lastrow = .Range("C" & Rows.Count).End(xlUp).Row

.Range("C1:C" & Lastrow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("B1"), _
Unique:=True

'delete temporay column C
.Columns("C").Delete

.Range("A1") = "SALES"
.Range("B1") = "ID"
.Range("C1") = "Employee"
.Range("D1") = "Hire Date"
.Range("E1") = "Manager"
.Range("F1") = "Reg"
.Range("G1") = "Title"

Lastrow = .Range("B" & Rows.Count).End(xlUp).Row
For RowCount = 2 To Lastrow
ID = .Range("B" & RowCount)

With SourceSht
Set c = .Columns("C").Find(what:=ID, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("Cannot find ID : " & ID)
Else
Sales = "N/A"
Reg = "N/A"
Employee = .Range("A" & c.Row)
HireDate = .Range("D" & c.Row)
Title = .Range("E" & c.Row)
Manager = .Range("G" & c.Row)
End If
End With

If Not c Is Nothing Then
.Range("A" & RowCount) = Sales
.Range("C" & RowCount) = Employee
.Range("D" & RowCount) = HireDate
.Range("E" & RowCount) = Manager
.Range("F" & RowCount) = Reg
.Range("G" & RowCount) = Title
Else
MsgBox ("Error : Count not find ID : " & ID)
End If
Next RowCount
End With

End Sub

Sub UpdateMaster()

Set Source = Workbooks("Source.xls")
Set SourceSht = Source.Sheets("Sheet1")
'Set SourceSht = Sheets("Sheet1")

Set Dest = Workbooks("Destination.xls")
'Set Dest = ThisWorkbook
Set DestSht = Dest.Sheets("Master")
With DestSht
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = Lastrow + 1
End With
With SourceSht

Lastrow = .Range("C" & Rows.Count).End(xlUp).Row
For RowCount = 2 To Lastrow
Sales = "N/A"
Reg = "N/A"
ID = .Range("C" & RowCount)
Employee = .Range("A" & RowCount)
HireDate = .Range("D" & RowCount)
Title = .Range("E" & RowCount)
Manager = .Range("G" & RowCount)

With DestSht
Set c = .Columns("B").Find(what:=ID, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
DataRow = NewRow
NewRow = NewRow + 1
.Range("B" & DataRow) = ID
Else
DataRow = c.Row
End If

.Range("A" & DataRow) = Sales
.Range("C" & DataRow) = Employee
.Range("D" & DataRow) = HireDate
.Range("E" & DataRow) = Manager
.Range("F" & DataRow) = Reg
.Range("G" & DataRow) = Title
End With
Next RowCount
End With

End Sub

Joel

unread,

Jul 7, 2009, 11:58:01 AM7/7/09

I found the error. I thought it would be simplier if you put the macro below
in a seperate workbook. the code will propt you to select a source an
destination file

Sub CreateMaster()

SourceToOpen = Application _
.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", _
Title:="Select Source file")
If SourceToOpen = False Then
MsgBox ("Cannot Open file - Exinting Macro")
Exit Sub
End If

DestToOpen = Application _
.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", _
Title:="Select Destination file")
If DestToOpen = False Then
MsgBox ("Cannot Open file - Exinting Macro")
Exit Sub
End If

Set Source = Workbooks.Open(Filename:=SourceToOpen)

Set SourceSht = Source.Sheets("Sheet1")
'Set SourceSht = Sheets("Sheet1")

Set Dest = Workbooks.Open(Filename:=DestToOpen)
'Set Dest = ThisWorkbook
Set DestSht = Dest.Sheets("WPS Detail Dates")

End Sub

Sub UpdateMaster()

Set Source = Workbooks.Open(Filename:=SourceToOpen)

Set SourceSht = Source.Sheets("Sheet1")
'Set SourceSht = Sheets("Sheet1")

Set Dest = Workbooks.Open(Filename:=DestToOpen)
'Set Dest = ThisWorkbook
Set DestSht = Dest.Sheets("WPS Detail Dates")

With SourceSht

End Sub

Kanmi

unread,

Jul 7, 2009, 4:24:01 PM7/7/09

Thanks alot. You've being so helpful. Whenever I run this it just pop up
empty vb code screen. please these link for the file then you will understand
what i'm talking about. i will appreciate if we can talk back to back and do
it together.

http://www.4shared.com/file/116382449/6ab0a56f/source.html
http://www.4shared.com/file/116382594/a06dcda8/destination.html

Please help me check the links and see if we talk back to back to resolve
it. I don't know how i can thank you for this. You are so helpful. Thanks

Joel

unread,

Jul 7, 2009, 6:52:01 PM7/7/09

The only real problem with the code was the columns were didfferent then what
you had posted. the macro runs extremely slow I believe due to the macros in
the destination workbook. You have change events and links in the
destination workbook that is slowing down the macro. If you don't think the
macro is working walk away for 4 hours and then come back.

Sub CreateMaster()

Set Source = Workbooks.Open(Filename:=SourceToOpen)
Set SourceSht = Source.Sheets("Sheet1")
'Set SourceSht = Sheets("Sheet1")

Set Dest = Workbooks.Open(Filename:=DestToOpen)
'Set Dest = ThisWorkbook
Set DestSht = Dest.Sheets("WPS Detail Dates")

Application.EnableEvents = False
With DestSht
LastRow = .Range("C" & Rows.Count).End(xlUp).Row
.Rows("9:" & LastRow).ClearContents
LastRow = SourceSht.Range("C" & Rows.Count).End(xlUp).Row
SourceSht.Range("C2:C" & LastRow).Copy _
Destination:=.Range("C9")
LastRow = .Range("C" & Rows.Count).End(xlUp).Row

'include B8 so advance filter doesn't leave
'two copoies of the 1st ID
.Range("C8:C" & LastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("B8"), _
Unique:=True

'restore B8
.Range("B8") = "EMP ID"
'delete temporay column C
.Range("C9:C" & LastRow).Delete

LastRow = .Range("B" & Rows.Count).End(xlUp).Row
For RowCount = 9 To LastRow

ID = .Range("B" & RowCount)

With SourceSht
Set c = .Columns("C").Find(what:=ID, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("Cannot find ID : " & ID)
Else
Sales = "N/A"
Reg = "N/A"
Employee = .Range("A" & c.Row)
HireDate = .Range("D" & c.Row)
Title = .Range("E" & c.Row)
Manager = .Range("G" & c.Row)
End If
End With

If Not c Is Nothing Then
.Range("A" & RowCount) = Sales
.Range("C" & RowCount) = Employee

.Range("D" & RowCount) = Manager

.Range("F" & RowCount) = Reg
.Range("G" & RowCount) = Title

.Range("H" & RowCount) = HireDate

Else
MsgBox ("Error : Count not find ID : " & ID)
End If
Next RowCount
End With

Application.EnableEvents = True

End Sub

Sub UpdateMaster()

Application.EnableEvents = False

Set Source = Workbooks.Open(Filename:=SourceToOpen)
Set SourceSht = Source.Sheets("Sheet1")
'Set SourceSht = Sheets("Sheet1")

Set Dest = Workbooks.Open(Filename:=DestToOpen)
'Set Dest = ThisWorkbook
Set DestSht = Dest.Sheets("WPS Detail Dates")

With DestSht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
End With

With SourceSht

LastRow = .Range("C" & Rows.Count).End(xlUp).Row
For RowCount = 2 To LastRow

ID = .Range("C" & RowCount)
Employee = .Range("A" & RowCount)
HireDate = .Range("D" & RowCount)
Title = .Range("E" & RowCount)
Manager = .Range("G" & RowCount)

With DestSht
Set c = .Columns("B").Find(what:=ID, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
DataRow = NewRow
NewRow = NewRow + 1
.Range("B" & DataRow) = ID

.Range("C" & DataRow) = Employee

.Range("D" & DataRow) = Manager
.Range("H" & DataRow) = HireDate

Else
DataRow = c.Row
If .Range("A" & DataRow) <> "N/A" And _
.Range("F" & DataRow) <> "N/A" Then

.Range("C" & DataRow) = Employee

.Range("D" & DataRow) = Manager
.Range("H" & DataRow) = HireDate

.Range("G" & DataRow) = Title

End If
End If

End With
Next RowCount
End With

Application.EnableEvents = True
End Sub

0 new messages