Automatic Data Management

K

Kanmi

Sub CreateMaster()

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

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

With DestSht
SourceSht.Columns("A:A").Copy _
Destination:=.Columns("D:D")
Lastrow = .Range("D" & Rows.Count).End(xlUp).Row

.Range("D1:D" & Lastrow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("C11"), _
Unique:=True

'delete temporay column D
.Columns("D").Delete
.Range("B11") = "MANAGER"
.Range("D11") = "ID"

Lastrow = .Range("C" & Rows.Count).End(xlUp).Row
For RowCount = 12 To Lastrow
Employee = .Range("C" & RowCount)

With SourceSht
Set c = .Columns("A").Find(what:=Employee, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("Cannot find employee : " & Employee)
Else
Manager = .Range("D" & c.Row)
ID = .Range("B" & c.Row)
End If
End With

If Not c Is Nothing Then
.Range("B" & RowCount) = Manager
.Range("D" & RowCount) = ID
End If
Next RowCount
End With

End Sub
-----------------------------------------------------------
I have a large two workbook (destination.xls and source.xls), that track
training of employee. The source.xls is link to the database such a way that
whenever i open, it pull Automatic update from the database. Manager has
list of employee under him that have undergone the training and these names
sometimes occur more than one time because they have two or more training.
I am trying to set up way that after update pulled by source.xls from the
database should Automatically copies to Destination.xls on a particular rows
and also only pick one name at a time if they appear more than one time"maybe
pick the first occured of each name" and cordinate the name by Manager.

For example

SOURCE.XLS
---------------- -A1:G1
A B C D E F
G
Employee Login ID ID Hire Date Title Email Manager
kim Belly kima 001 06/21/01 MD kim@ Jen
kim Belly kima 001 06/21/01 MD kim@ Jen
Fue Lee leeo 002 02/07/02 SALES leeo@ Mark
Ben Jud bee 003 02/07/02 MD bee@ JEN
Yao yu yao 004 02/25/05 MA yao@ Tim-
Yao yu yao 004 02/25/05 MA yao@ Tim
Yao yu yao 004 02/25/05 MA yao@ Tim

DESTINATION.XLS
----------------------
A B C D E F
G
SALES ID Employee Hire Date Manager Reg Title
N/A 001 KIM BELLY 06/21/01 JEN N/A MD
N/A 003 BEN JUD 02/07/02 JEN N/A MD
N/A 002 FUE LEE 02/07/02 MARK N/A SALES
N/A 004 YAO YO 02/25/05 TIM N/A MA

This is how the page appeared on each workbook and i have arrange
destination.xls the way i want it to work. I want destination.xls
automatically pulled update from source.xls and list them according to the
manager and even if new students were added then should automatically appear
under it manager. I got the VB CODE ABOVE TO EDIT AND SEE OTHER WAYS TO
ACHIEVE THIS.

I know this might hard to go through but i will appreciate any advice or
help because it all chanllenge. Thanks and God bless you.
 
K

ker_01

Kanmi-

Check the Excel VBA help file for "Match"- if you want to avoid duplicates,
use the Match function to see if the item already exists. If not, add the
row; if it does already exist, then skip to the next row of data.

Try searching past posts for "Match" to find code snippets to fully
understand how it can be used and then incorporate into your existing code as
needed.

HTH,
Keith
 
J

Joel

I wrote 2 macros. One for creating the initial master sheet and one for
updating the master sheet. Originally your code had the source sheet
starting in row 11, I modified the code to now start a row 1 since this
request specified the source starting at row 1.


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
 
K

Kanmi

Oh you are amazing. Thank you very much. Please i don't want to create a new
sheet in destination.xls. the sheet is already existing, name "WPS Detail
Dates" and which workbook will I insert the code. Whenever i put the code in
and go back to the excel page nothing happen. Did I need to enable something
before it start runing. please explain more. Thanks so much for your help.
 
J

Joel

I changed the destination worksheet name in the code below. I can add dialog
windows so the user can open the workbooks when the macro is running. For
the code to 3 workbooks need to be opened

1) the workbook with the macro
2) The source workbook - "Source.xls"
3) the destination workbook - "Destination.xls"

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

DestSht.Name = "WPS Detail Dates"
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("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

Hello Joel. You are Amazing!. Thanks alot. The scripts below is working but
is creating a new master "sheet". No there is existing sheet name "WPS Detail
Dates" which i want the information to appear.I want skip or exclude rows A
and F (N/A). I don't the scripts to affect them" They showing N/A" I want to
free those rows.

NOTE. I tried to edit it not to create new master sheet and insert the
information in sheet "WPS Detail Dates" but it showing ERROR " RUN-TIME
ERROR 424" OBJECT REQUIRED. So please help me look into it. Thanks alot.
 
K

Kanmi

Hello Joel. You are Amazing!. Thanks alot. The scripts below is working but
is creating a new master "sheet". No there is existing sheet name "WPS Detail
Dates" which i want the information to appear.I want skip or exclude rows A
and F (N/A). I don't the scripts to affect them" They showing N/A" I want to
free those rows.

NOTE. I tried to edit it not to create new master sheet and insert the
information in sheet "WPS Detail Dates" but it showing ERROR " RUN-TIME
ERROR 424" OBJECT REQUIRED. So please help me look into it. Thanks alot.

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

There are two macros in the code I sent. the 1st one is intended for a new
data and the second is for updating an existing workbook. The 2nd should
work in either case.

You should be running the 2nd macro. I made one change to the 1st macro to
clear all cells in destination sheet assuming you want to add all data. I
changed the 2nd macro to test for N/A in columns A and F.

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
.Cells.ClearContents
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
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) = HireDate
.Range("E" & DataRow) = Manager
.Range("F" & DataRow) = Reg

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

.Range("C" & DataRow) = Employee
.Range("D" & DataRow) = HireDate
.Range("E" & DataRow) = Manager
.Range("G" & DataRow) = Title
End If
End If

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
 

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

Run-Time Error "9". Subscript out of range 3
ERROR 424" OBJECT REQUIRED 1
AUTOMATIC DATA ENTRY 4
VB CODE ERROR 2
Automatic copy between two workbooks 4
HOW CAN I INSERT DATA BTW TWO WORKBOOK 1
Automatic Data Insertion Between Workbooks 1
copy data in turqouise colour cells from n to a 2

Top