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

K

Kanmi

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
 
J

Joel

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")

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()

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")

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
 
K

Kanmi

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
 
J

Joel

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()

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")

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()

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

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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

create new worksheet"ERROR" 0
ERROR 424" OBJECT REQUIRED 1
Copy Data Between two Workbook 0
Automatic Data Management 8
VB CODE EDITOR 0
Search CSV for string. 5
Joel - Data Consolidate Limitation 0
Help Change existing Code 6

Top