script to send data from worksheet to multiple workbooks

[Greg]

Hi. Can anybody offer me some words of wisdom on how to approach the
following...

I want to create a data entry worksheet that links to multiple
workbooks. To be more specific, the data entry worksheet is a school
class mark book with perhaps up to 30 students listed with their
grades entered into the relevent columns.

I then would like to send each row of information (student name and
grades) into the individual workbook for that student. The individual
workbook contains worksheets for a student for all year levels that
they are in over a 5 year period. The individual workbook is
basically a profile where all the grades are crunched to provide a
level of achievement.

The individual workbook that crunches the numbers works beautifully.
I am just trying to simplify data entry by developing a "mark book"
where the data is then placed into each workbook. It is a drama to
open each student workbook individually and enter data. Any
suggestions??

Greg

 

[Susan]

yes, you can do this.
to make it easier i would handle it this way.....

in worksheet, student's name is:
Smith, Robert

individual workbook for that student would be named
Smith_personalgrades.xls

then you can have a macro in the main workbook go down each row of the
column that contains the student's names, extract the last name (all
text before the comma) & call that variable sStudentName. have
"_personalgrades.xls" saved as a variable. open workbook
"sStudentName" & "_personalgrades.xls".
copy & paste appropriate range info (that row & columns a-c, for
instance).
save & close student workbook.
go on to next student.

obviously this will take a lot of coding, but when you're done, it
will work very quickly & do it all at once.
i do something similar for my boss only the other way around with
individual workbooks to the master workbook.
hope this gets you started in the right direction!
susan

 

[Greg]

yes, you can do this.
to make it easier i would handle it this way.....

in worksheet, student's name is:
Smith, Robert

individual workbook for that student would be named
Smith_personalgrades.xls

then you can have a macro in the main workbook go down each row of the
column that contains the student's names, extract the last name (all
text before the comma) & call that variable sStudentName. have
"_personalgrades.xls" saved as a variable. open workbook
"sStudentName" & "_personalgrades.xls".
copy & paste appropriate range info (that row & columns a-c, for
instance).
save & close student workbook.
go on to next student.

obviously this will take a lot of coding, but when you're done, it
will work very quickly & do it all at once.
i do something similar for my boss only the other way around with
individual workbooks to the master workbook.
hope this gets you started in the right direction!
susan







- Show quoted text -

Thanks Susan

I don't suppose you can point to something similar to what you
suggested? My skill in writing scripts is below limited! I have had
good success in achieving my goals by finding a script that does
something similar to what I want and then spend hours reverse
engineering it and changing it to suit.

Greg

 

[Susan]

sorry for the delay, greg, i don't have internet access on the
weekend........
yes, here is some working coding........
like i said, this is somewhat backwards, but it should give you some
ideas. this is a monthly workbook that when you press the "update"
button it calls up a userform in which my boss can choose which
program's info she wants to export, then automatically exports the
info to a master workbook (RPCbook1.xls). the macro is stored in the
monthly book, called invoices.xls.

future improvements: the "if month" section could probably be changed
to a case statement, but i haven't worked on that yet. also, the
whole "if chkbox*** = true then" could be made into a case statement
with a variable for the program name. complete the "add new" feature.


hope this helps!
module names are listed.

in the interim i will work on something small that does what you
specifically wanted.
susan

===========================

Document: <date>Invoices.xls
Module: GlobalDeclarations

Option Explicit

Public wbMyInvoices As Workbook
Public wsMyIndirectSheet As Worksheet
Public wbMyRPC As Workbook
Public wsMyRPCSheet As Worksheet

Public Month, m, PrevMonth As Integer
Public dt As Date

Public Jan, Feb, Mar As Worksheet
Public Apr, May, Jun As Worksheet
Public Jul, Aug, Sep As Worksheet
Public Oct, Nov, Dec As Worksheet
Public Sum As Worksheet

Public r As Range
Public StartRow, EndRow As Long
Public rFound, myCosts, StartPoint As Range
Public InvoicePercent, RPCPercent, rReturn As Range

Public chkTotal, chkAHC06, chkDANC05 As Control
Public chkHPG05, chkHPG06, chkLCHOME05 As Control
Public chkCHDO06, chkCro, chkLCHBYR05 As Control
Public chkMicro, chkAccess, chkRentals, chkRPC As Control
Public chkKeepOpen As Boolean

Public chkAddNew, chkNew, refNewName As Control
Public myNewName, myProgram As String

Public cmdExport As Control


Public Sub MonthNumber()

'Set Current Date.
dt = DateTime.Date

'Break up the date.
m = DateTime.Month(dt)

If m <= 1 Then
PrevMonth = (m + 11)
End If

If m >= 2 Then
PrevMonth = (m - 1)
End If

End Sub

Public Sub Select_Sheet()

Set Jan = Workbooks("RPC Book1.xls").Worksheets("Sheet1")
Set Feb = Workbooks("RPC Book1.xls").Worksheets("Sheet2")
Set Mar = Workbooks("RPC Book1.xls").Worksheets("Sheet3")
Set Apr = Workbooks("RPC Book1.xls").Worksheets("Sheet4")
Set May = Workbooks("RPC Book1.xls").Worksheets("Sheet5")
Set Jun = Workbooks("RPC Book1.xls").Worksheets("Sheet6")
Set Jul = Workbooks("RPC Book1.xls").Worksheets("Sheet7")
Set Aug = Workbooks("RPC Book1.xls").Worksheets("Sheet8")
Set Sep = Workbooks("RPC Book1.xls").Worksheets("Sheet9")
Set Oct = Workbooks("RPC Book1.xls").Worksheets("Sheet10")
Set Nov = Workbooks("RPC Book1.xls").Worksheets("Sheet11")
Set Dec = Workbooks("RPC Book1.xls").Worksheets("Sheet12")
Set Sum = Workbooks("RPC Book1.xls").Worksheets("Summary")

If PrevMonth = 1 Then
Jan.Select
End If

If PrevMonth = 2 Then
Feb.Select
End If

If PrevMonth = 3 Then
Mar.Select
End If

If PrevMonth = 4 Then
Apr.Select
End If

If PrevMonth = 5 Then
May.Select
End If

If PrevMonth = 6 Then
Jun.Select
End If

If PrevMonth = 7 Then
Jul.Select
End If

If PrevMonth = 8 Then
Aug.Select
End If

If PrevMonth = 9 Then
Sep.Select
End If

If PrevMonth = 10 Then
Oct.Select
End If

If PrevMonth = 11 Then
Nov.Select
End If

If PrevMonth = 12 Then
Dec.Select
End If

Set rReturn = ActiveSheet.Range("a2")

End Sub


Module: OpenForm
Option Explicit

Sub MyExports_click()

Load UserForm1
UserForm1.Show

End Sub


Module: ExportValues
Option Explicit

Public Sub ActualCopy()

Set r = wsMyIndirectSheet.Columns("G")

'find the program name in wsMyIndirectSheet

Set rFound = r.Find(What:=myProgram, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
MatchCase:=False)

If rFound Is Nothing Then
MsgBox "Sorry, " & myProgram & " was not found" _
& vbCrLf & _
"in the Invoice sheet."
Exit Sub
End If

StartRow = rFound.End(xlToLeft) _
.End(xlToLeft).End(xlDown).End(xlDown).Row

EndRow = rFound.End(xlToLeft).End(xlToLeft) _
.End(xlDown).End(xlDown) _
.End(xlDown).Offset(-1, 0).Row

'set the 2 ranges you will need to copy

Set myCosts = wsMyIndirectSheet.Range("h" & StartRow & ":h" & EndRow)

Set InvoicePercent = rFound.Offset(5, -1)

myCosts.Copy

'find the appropriate column in wsMyRPCSheet
'& then paste

Set StartPoint = wsMyRPCSheet.Range("a4")

Set r = StartPoint.EntireRow

Set rFound = r.Find(What:=myProgram, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
MatchCase:=False)

If rFound Is Nothing Then
MsgBox "Sorry, " & myProgram & " was not found" _
& vbCrLf & _
"in the RPC sheet."
Exit Sub
End If

Set StartPoint = rFound.Offset(1, 0) '.Address

StartPoint.PasteSpecial (xlPasteValues)

'then offset 5 columns (to column F) for

InvoicePercent.Copy

Set RPCPercent = rFound.Offset(20, 0)

RPCPercent.PasteSpecial (xlPasteValues)

End Sub


Public Sub Overhead()

'Public wsMyIndirectSheet As Worksheet
'Public wsMyRPCSheet As Worksheet

wsMyRPCSheet.Range("n25") = wsMyIndirectSheet.Range("q1")
wsMyRPCSheet.Range("n26") = wsMyIndirectSheet.Range("q2")
wsMyRPCSheet.Range("n27") = wsMyIndirectSheet.Range("q4")
wsMyRPCSheet.Range("n28") = wsMyIndirectSheet.Range("q3")

End Sub


Module: Userform1 code
Option Explicit
'
'this workbook contains a
'set of macros designed and developed
'by Susan
'for xxxxxx
'completed 12/22/06 except for
'add new boxes; maybe do later
'
'revised 12/29/06 to add progress
'bar coding
'revised 2/13/07 to add HPG 2006 & remove
'Croghan CDBG
'

Sub UserForm_Initialize()

'check all the boxes automatically except for
'the keepopen and addnew checkboxes

Dim oControl As Control
For Each oControl In Me.Controls
If TypeOf oControl Is msforms.CheckBox Then
oControl.Value = True
End If
Next oControl

With Me
..chkAddNew.Value = False
..chkKeepOpen.Value = False
..cmdExport.SetFocus
End With

End Sub


Sub cmdExport_click()

Me.Hide

'check if the addnew checkbox is true
'if it is, then call addanother (in future)

If Me.chkAddNew.Value = True Then
MsgBox "The ""Add a New Program"" feature is currently not available."
_
& vbCrLf & _
vbCrLf & _
"Please e-mail Susan and have her add the new program manually." _
& vbCrLf & _
vbCrLf & _
" Signed, your friend, the Computer.", vbOKOnly,
"Whoops!"
End If

Application.ScreenUpdating = False

call Main

Unload Me

Application.ScreenUpdating = True

MsgBox "All values have been exported." _
& vbCrLf & _
vbCrLf & _
"Have a nice day!", vbOKOnly, "We're finished now..."

End Sub


Module: MainProgram
Option Explicit

Sub Main()

ProgressForm.chkWkshtCode.Value = True

Set wbMyInvoices = ThisWorkbook
Set wsMyIndirectSheet = ActiveSheet

Workbooks.Open Filename:="\\Server\users\Susan\My Documents
\Miscellaneous\Excel Help\Macro Projects-Excel\RPC Book1.xls"

'open the correct worksheet by month
Call MonthNumber
Call Select_Sheet

Set wbMyRPC = ActiveWorkbook
Set wsMyRPCSheet = ActiveSheet

'go thru all the checkboxes & copy if needed

If UserForm1.chkTotal.Value = True Then
myProgram = UserForm1.chkTotal.Caption
Call ActualCopy
End If

If UserForm1.chkAHC06.Value = True Then
myProgram = UserForm1.chkAHC06.Caption
Call ActualCopy
End If

If UserForm1.chkDANC05.Value = True Then
myProgram = UserForm1.chkDANC05.Caption
Call ActualCopy
End If

'If UserForm1.chkHPG05.Value = True Then
'myProgram = UserForm1.chkHPG05.Caption
'Call ActualCopy
'End If

If Userform1.chkHPG06.Value = True Then
myProgram = UserForm1.chkHPG06.Caption
Call ActualCopy
End If

If UserForm1.chkLCHOME05.Value = True Then
myProgram = UserForm1.chkLCHOME05.Caption
Call ActualCopy
End If

If UserForm1.chkCHDO06.Value = True Then
myProgram = UserForm1.chkCHDO06.Caption
Call ActualCopy
End If

'If UserForm1.chkCro.Value = True Then
'myProgram = UserForm1.chkCro.Caption
'Call ActualCopy
'End If

If UserForm1.chkLCHBYR05.Value = True Then
myProgram = UserForm1.chkLCHBYR05.Caption
Call ActualCopy
End If

If UserForm1.chkMicro.Value = True Then
myProgram = UserForm1.chkMicro.Caption
Call ActualCopy
End If

'If Userform1.chkAccess.Value = True Then
'myProgram = UserForm1.chkAccess.Caption
'Call ActualCopy
'End If

If UserForm1.chkRentals.Value = True Then
myProgram = UserForm1.chkRentals.Caption
Call ActualCopy
End If

If UserForm1.chkRPC.Value = True Then
myProgram = UserForm1.chkRPC.Caption
Call ActualCopy
End If

'after all values exported, save both workbooks
'check if keepopen chkbox is true
'if not, close wbMyRPC

Call Overhead

rReturn.Select

If UserForm1.chkKeepOpen.Value = False Then
Application.DisplayAlerts = False
wbMyRPC.Save
wbMyRPC.Close
Application.DisplayAlerts = True
End If

wbMyInvoices.Save

End Sub

=============================

 

[Susan]

ok, greg, here's what i've got for you.
this is controlled by a command button on the main worksheet.......

Option Explicit

Private Sub CommandButton1_Click()

Call Export

End Sub


Option Explicit

Public lName As String
Public fName As String
Public mName As String
Public sRank As String
Public iloc As Integer
Public rRange, GroupRange, PersonRange As Range
Public wb1, wb2 As Workbook
Public ws1, ws2 As Worksheet
Public iRow, iiRow As Integer
Public c As Range
Public sStudent As String
Public sFile, sPath As String
'

Public Sub Export()

Set wb1 = ActiveWorkbook
Set ws1 = ActiveSheet

'CHANGE rRange TO YOUR ACTUAL RANGE OF
'STUDENT'S NAMES
Set rRange = ws1.Range("a3:a7")

'CHANGE sPath TO YOUR ACTUAL PATH
sPath = "\\Server\users\Susan\My Documents\Miscellaneous\01Excel\Macro
Projects-Excel\Tests\PersonalWkbks\"

'go to the top of the range that has the student's names
ws1.Range("a3").Select
iRow = ActiveCell.Row

For Each c In rRange
'this is the range of the old workbook with all the students
'that is JUST the row of the one student you're working
'on
Set GroupRange = ws1.Range("b" & iRow & ":g" & iRow)

Call SplitName(c)

sStudent = lName
sFile = "_personalgrades.xls"
Workbooks.Open Filename:=sPath & sStudent & sFile

Set wb2 = ActiveWorkbook
Set ws2 = ActiveSheet
'iiRow is the first blank row in column B - column A contains
'the student's name in my sample workbook.

iiRow = ws2.Cells(5000, 2).End(xlUp).Offset(1, 0).Row
'this is the range in the individual's workbook
'it contains just one row
Set PersonRange = ws2.Range("b" & iiRow & ":g" & iiRow)

GroupRange.Copy
PersonRange.PasteSpecial

wb2.Save
wb2.Close
iRow = iRow + 1

Next c

End Sub


Public Sub SplitName(sName)

sName = Trim(sName) 'this is taking spaces off the end or beginning
of the name
iloc = InStr(sName, ",") 'this is the # position of the comma
lName = Left(sName, iloc - 1) 'this is the last name, before the
comma

'sub above taken from newsgroup with this
'disclaimer from Tom:
'the sub above won't correctly handle
'
'Smith, Joe Bob R. Pvt
'Smith, Mike Cpl
'Smith, Bill H Pfc
'
'Regards,
'Tom Ogilvy

End Sub


it worked for me with limited testing.
HTH!

susan

 

[Greg]

ok, greg, here's what i've got for you.
this is controlled by a command button on the main worksheet.......

Option Explicit

Private Sub CommandButton1_Click()

Call Export

End Sub

Option Explicit

Public lName As String
Public fName As String
Public mName As String
Public sRank As String
Public iloc As Integer
Public rRange, GroupRange, PersonRange As Range
Public wb1, wb2 As Workbook
Public ws1, ws2 As Worksheet
Public iRow, iiRow As Integer
Public c As Range
Public sStudent As String
Public sFile, sPath As String
'

Public Sub Export()

Set wb1 = ActiveWorkbook
Set ws1 = ActiveSheet

'CHANGE rRange TO YOUR ACTUAL RANGE OF
'STUDENT'S NAMES
Set rRange = ws1.Range("a3:a7")

'CHANGE sPath TO YOUR ACTUAL PATH
sPath = "\\Server\users\Susan\My Documents\Miscellaneous\01Excel\Macro
Projects-Excel\Tests\PersonalWkbks\"

'go to the top of the range that has the student's names
ws1.Range("a3").Select
iRow = ActiveCell.Row

For Each c In rRange
'this is the range of the old workbook with all the students
'that is JUST the row of the one student you're working
'on
Set GroupRange = ws1.Range("b" & iRow & ":g" & iRow)

Call SplitName(c)

sStudent = lName
sFile = "_personalgrades.xls"
Workbooks.Open Filename:=sPath & sStudent & sFile

Set wb2 = ActiveWorkbook
Set ws2 = ActiveSheet
'iiRow is the first blank row in column B - column A contains
'the student's name in my sample workbook.

iiRow = ws2.Cells(5000, 2).End(xlUp).Offset(1, 0).Row
'this is the range in the individual's workbook
'it contains just one row
Set PersonRange = ws2.Range("b" & iiRow & ":g" & iiRow)

GroupRange.Copy
PersonRange.PasteSpecial

wb2.Save
wb2.Close
iRow = iRow + 1

Next c

End Sub

Public Sub SplitName(sName)

sName = Trim(sName) 'this is taking spaces off the end or beginning
of the name
iloc = InStr(sName, ",") 'this is the # position of the comma
lName = Left(sName, iloc - 1) 'this is the last name, before the
comma

'sub above taken from newsgroup with this
'disclaimer from Tom:
'the sub above won't correctly handle
'
'Smith, Joe Bob R. Pvt
'Smith, Mike Cpl
'Smith, Bill H Pfc
'
'Regards,
'Tom Ogilvy

End Sub

it worked for me with limited testing.
HTH!

susan

Ah Susan! Your an angel!!! Thank you so much. You really must have
a passion for this stuff.

Greg

 

[Susan]

yep...... guilty as charged!
i'm very glad it worked!
a lot of it is just learning to comb the newsgroup & pulling out bits
& pieces of what you need, and then combining it to work as one sub.
susan