Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > Run-Time Error "9". Subscript out of range
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 76
Default Run-Time Error "9". Subscript out of range

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



Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 9,101
Default Run-Time Error "9". Subscript out of range
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




"Kanmi" wrote:

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



Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 76
Default Run-Time Error "9". Subscript out of range

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/11638244...6f/source.html
http://www.4shared.com/file/11638259...stination.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" wrote:

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




"Kanmi" wrote:

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



Reply With QuoteReply With Quote
  #4   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 9,101
Default Run-Time Error "9". Subscript out of range

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





"Kanmi" wrote:

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/11638244...6f/source.html
http://www.4shared.com/file/11638259...stination.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" wrote:

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




"Kanmi" wrote:

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


Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
"Subscript out of range" error for: Workbooks("Test1.xls").Save Just12341234 Excel Programming 2 June 17th 05 03:16 PM
FileCopy Command Giving "Subscript Out of Range" Error Message Jim Hagan Excel Programming 2 June 15th 05 06:07 PM
strange "subscript out of range" error! behnood Excel Programming 3 February 17th 04 08:26 AM
SaveAs "subscript out of range" error (COM - SOAP) Matthia Excel Programming 0 July 11th 03 07:01 AM
SaveAs "subscript out of range" error (COM - SOAP) jaf Excel Programming 0 July 10th 03 07:59 PM


All times are GMT +1. The time now is 06:22 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement