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
|