I need to create a 3 workbooks with multiple worksheets (10-20 sheets per workbook) at different times in a year. At the end of the year I need to pickup related worksheets from this 3 workbooks and combine them as a new workbook. Is there an automated way of doing this? Please see the attachment for the pattern and naming convention of the desired workbook? Appreciate any help.
![]() |
Patch reliability is unclear. Unless you have an immediate, pressing need to install a specific patch, don't do it. |
SIGN IN | Not a member? | REGISTER | PLUS MEMBERSHIP |
-
Make Break Recombine (Excel 2002)
Home » Forums » AskWoody support » Productivity software by function » MS Excel and spreadsheet help » Make Break Recombine (Excel 2002)
- This topic has 19 replies, 4 voices, and was last updated 19 years, 6 months ago.
Viewing 1 reply threadAuthorReplies-
H. Legare Coleman
AskWoody PlusNovember 10, 2005 at 2:13 pm #984353This can be done with some VBA code, but we would need to know a lot more about what those workbooks and worksheets look like. The easiest way would be for you to attach a sample workbook that we could use to test the VBA code on. The workbook can contain dummy data so as not to expose any confidential data.
-
WSjolas
AskWoody LoungerNovember 10, 2005 at 11:42 pm #984471Here is the link to the files. The Term1,2,3 workbooks may contain 10~20 sheets. At the end of the year I’d like to extract the student files from the Term1,2,3 workbooks consolidated in a workbook. The resulting files names would follow a pattern like this “NameOfStudent+SchoolYear.xls” (e.i. Jane0506.xls).
Thanks for taking an interest on this.
Regards
jolas -
WSSammyB
AskWoody LoungerNovember 11, 2005 at 3:43 pm #984506If you place this macro in a blank workbook, it should do the trick. I’m also attaching a blank workbook with the macro. Be sure that all the gradebooks are closed before starting the macro. HTH –Sam
Option Explicit Sub Consolidate() 'Get list of gradebooks. 'If XL kept the list as selected, we could use it, 'but it dosen't anymore, so we just use the list as 'a name template and always open 3 gradebooks. 'It would be better to sort the list and open each 'workbook in the list. Dim list As Variant, sFilter As String Dim iGradeBook As Long, iStudent As Long Dim wbGrade(1 To 3) As Workbook, wbStu() As Workbook Dim sFile As String, sSuffix As String sFilter = "Excel Workbooks (*.xl?), *.xl?, All Files (*.*), *.*" list = Application.GetOpenFilename(filefilter:=sFilter, _ Title:="Select Workbooks to Consolidate", MultiSelect:=True) On Error GoTo pressedCancel iGradeBook = LBound(list) ' Check for Cancel On Error GoTo 0 sFile = list(LBound(list)) sSuffix = Right(sFile, 13) ' _PBm_nnnn.xls sFile = Left(sFile, Len(sFile) - 14) sFile = sFile & "*" & sSuffix sSuffix = Right(sFile, 8) ' nnnn.xls 'Collect student names and open gradebooks Dim cStudents As New Collection For iGradeBook = 1 To 3 Set wbGrade(iGradeBook) = Workbooks.Open _ (Filename:=Replace(sFile, "*", iGradeBook), ReadOnly:=True) collectNames wbGrade(iGradeBook), cStudents Next iGradeBook 'Create Student workbooks Dim n As Long, sName As String, ws As Worksheet n = cStudents.Count ReDim wbStu(1 To n) For iStudent = 1 To n sName = cStudents(iStudent) For iGradeBook = 1 To 3 Set ws = getSheet(sName, wbGrade(iGradeBook)) If Not ws Is Nothing Then If wbStu(iStudent) Is Nothing Then ws.Copy Set wbStu(iStudent) = ActiveWorkbook Else With wbStu(iStudent) ws.Copy after:=.Worksheets(.Worksheets.Count) End With End If End If Next iGradeBook wbStu(iStudent).SaveAs sName & sSuffix wbStu(iStudent).Close Next iStudent 'Close GradeBooks For iGradeBook = LBound(wbGrade) To UBound(wbGrade) wbGrade(iGradeBook).Close savechanges:=False Next iGradeBook pressedCancel: End Sub Private Sub collectNames(wb As Workbook, cStudents As Collection) Dim ws As Worksheet, s As String For Each ws In wb.Worksheets s = Left(ws.Name, Len(ws.Name) - 2) On Error Resume Next 'skip duplicate names cStudents.Add Item:=s, key:=s On Error GoTo 0 Next ws End Sub Private Function getSheet(sName As String, wb As Workbook) As Worksheet Dim ws As Worksheet, s As String For Each ws In wb.Worksheets s = Left(ws.Name, Len(ws.Name) - 2) If s = sName Then Set getSheet = ws Exit Function End If Next ws Set getSheet = Nothing ' if not found End Function
-
H. Legare Coleman
AskWoody PlusNovember 11, 2005 at 3:50 pm #984509Does this code do what you want? Put the code in a separate workbook and change the line:
strPath = "C:Work123"
[/codeto point to the directory where the files are located. The code assumes that none of the individual files exists.
Public Sub SplitTerm()
Dim strPath As String, strFName As String
Dim oSWB As Workbook, oTWB As Workbook
Dim oSWS As Worksheet, oTWS As Worksheet
Dim lSINWB As Long
Application.ScreenUpdating = False
strPath = "C:Work123"
lSINWB = Application.SheetsInNewWorkbook
strFName = Dir(strPath & "Term*.xls", vbNormal)
Do While strFName ""
Set oSWB = Workbooks.Open(strPath & strFName)
For Each oSWS In oSWB.Worksheets
On Error Resume Next
Set oTWB = Nothing
Set oTWB = Workbooks.Open(strPath & Left(oSWS.Name, Len(oSWS.Name) - 2) & "123")
On Error GoTo 0
If oTWB Is Nothing Then
Application.SheetsInNewWorkbook = 1
Set oTWB = Workbooks.Add
oTWB.SaveAs (strPath & Left(oSWS.Name, Len(oSWS.Name) - 2) & "123")
End If
Set oTWS = oTWB.Worksheets.Add(After:=oTWB.Worksheets(oTWB.Worksheets.Count))
oTWS.Name = oSWS.Name
oSWS.Cells.Copy
oTWS.Paste Destination:=oTWS.Range("A1")
Application.CutCopyMode = False
oTWB.Save
oTWB.Close
Next oSWS
oSWB.Close
strFName = Dir
Loop
Application.ScreenUpdating = True
End Sub
-
WSjolas
AskWoody LoungerNovember 12, 2005 at 12:21 pm #984694Thanks to Sammy and Legare for showing a couple of ways to provide automation solution to my problem. I forgot to mention that a lot of the merged cells contain a lot of text mostly breaking the wrap text formatting. I know that excel does not handle text well so when I tried Sammy’s code the task was wonderfully accomplished but a lot of the text were truncated. Is there a way around it?
Legare’s code did what I wanted but I just noticed that an extra blank sheet was included in each resulting workbook. Also grid lines from the source workbook were hidden but the resulting workbook are showing the gridlines not a problem but nicer if formatting were retained. The print settings which is important seemed amiss aswell. Is there a way around this aswell?
Regards
jolas -
H. Legare Coleman
AskWoody PlusNovember 12, 2005 at 1:52 pm #984709Here is a version that gets rid of the extra worksheet and the gridlines. I would need to know what print settings you want to preserve to fix that. There are many print settings, and setting many of them is very slow, so I would only want to set the ones that are important.
Public Sub SplitTerm()
Dim strPath As String, strFName As String
Dim oSWB As Workbook, oTWB As Workbook
Dim oSWS As Worksheet, oTWS As Worksheet, oS1 As Worksheet
Dim lSINWB As Long
Application.ScreenUpdating = False
strPath = "C:Work123"
lSINWB = Application.SheetsInNewWorkbook
strFName = Dir(strPath & "Term*.xls", vbNormal)
Do While strFName ""
Set oSWB = Workbooks.Open(strPath & strFName)
For Each oSWS In oSWB.Worksheets
On Error Resume Next
Set oTWB = Nothing
Set oTWB = Workbooks.Open(strPath & Left(oSWS.Name, Len(oSWS.Name) - 2) & "123")
On Error GoTo 0
If oTWB Is Nothing Then
Application.SheetsInNewWorkbook = 1
Set oTWB = Workbooks.Add
oTWB.SaveAs (strPath & Left(oSWS.Name, Len(oSWS.Name) - 2) & "123")
End If
Set oTWS = oTWB.Worksheets.Add(After:=oTWB.Worksheets(oTWB.Worksheets.Count))
oTWS.Name = oSWS.Name
On Error Resume Next
Set oS1 = Nothing
Set oS1 = oTWB.Worksheets("Sheet1")
If Not oS1 Is Nothing Then
Application.DisplayAlerts = False
oS1.Delete
Application.DisplayAlerts = True
End If
oSWS.Cells.Copy
oTWS.Paste Destination:=oTWS.Range("A1")
Application.CutCopyMode = False
ActiveWindow.DisplayGridlines = False
oTWB.Save
oTWB.Close
Next oSWS
oSWB.Close
strFName = Dir
Loop
Application.ScreenUpdating = True
End Sub
-
WSSammyB
AskWoody LoungerNovember 12, 2005 at 4:37 pm #984728> a lot of the text were truncated
Can you populate your sample gradebook with fake data that gets truncated with my code? I’ve always said that Excel hated merged cells, and now it looks like I was correct.> print settings which is important seemed amiss
we can probably fix that by using an instructor’s gradebook as a template for the student gradebooks. I’ll incorporate that after you send some fake data. Make sure that the sample instructor gradebooks have the correct print settings. -
WSjolas
AskWoody Lounger -
WSSammyB
AskWoody LoungerNovember 13, 2005 at 2:34 am #984794Nothing like real data to break your code! But, only one line to change:
.Worksheets(.Worksheets.Count).Cells(c.Row, c.Column).FormulaR1C1 = c.Text should be c.MergeArea.Copy .Worksheets(.Worksheets.Count).Cells(c.Row, c.Column).MergeArea
First time I’ve ever used the MergeArea method, so I’ve learned something. Now if I could just learn read those grade reports! I’ve attached the workbook with the correct code. –Sam
-
WSjolas
AskWoody Lounger -
WSHansV
AskWoody LoungerNovember 13, 2005 at 9:52 am #984809 -
WSjolas
AskWoody LoungerNovember 13, 2005 at 11:01 am #984819Typo on my previous post. Student.xls should refer to the Student.xlt as highlighted on the attachment. Hans, I’ve not rename nor move any file as I just would run the macro from SammyB’s attachment, point to the 3 Workbooks that it need to process and come out with the resulting workbooks that I desired. Another set of code guru eyes – surely this will be heading in the right direction. Appreciate your input.
-
WSSammyB
AskWoody LoungerNovember 13, 2005 at 12:32 am #984783What a mess! Turns out that when you copy an entire sheet, XL only copies the first 255 characters in a cell. So, I manually recopy each cell that has > 255 characters. The template thingie that I mentioned earlier worked a treat, so at least we didn’t manually have to do it. As Legare said, it gets ugly. Here is the final macro, plus I’ve attached a blank workbook with just the macro. In addition, get the student gradebook template from the next post. This consolidate workbook, the template, and the teacher gradebooks must be in the same directory. HTH –Sam
Option Explicit Sub Consolidate() 'Get list of gradebooks. 'If XL kept the list as selected, we could use it, 'but it dosen't anymore, so we just use the list as 'a name template and always open 3 gradebooks. 'It would be better to sort the list and open each 'workbook in the list. Dim list As Variant, sFilter As String Dim iGradeBook As Long, iStudent As Long Dim wbGrade(1 To 3) As Workbook Dim sFile As String, sSuffix As String sFilter = "Excel Workbooks (*.xl?), *.xl?, All Files (*.*), *.*" list = Application.GetOpenFilename(filefilter:=sFilter, _ Title:="Select Workbooks to Consolidate", MultiSelect:=True) On Error GoTo pressedCancel iGradeBook = LBound(list) ' Check for Cancel On Error GoTo 0 sFile = list(LBound(list)) sSuffix = Right(sFile, 13) ' _PBm_nnnn.xls sFile = Left(sFile, Len(sFile) - 14) sFile = sFile & "*" & sSuffix sSuffix = Right(sFile, 8) ' nnnn.xls 'Collect student names and open gradebooks Dim cStudents As New Collection For iGradeBook = 1 To 3 Set wbGrade(iGradeBook) = Workbooks.Open _ (Filename:=Replace(sFile, "*", iGradeBook), ReadOnly:=True) collectNames wbGrade(iGradeBook), cStudents Next iGradeBook 'Create Student workbooks Dim n As Long, sName As String, ws As Worksheet n = cStudents.Count For iStudent = 1 To n sName = cStudents(iStudent) Application.ScreenUpdating = False With Workbooks.Add("Student.xlt") For iGradeBook = 1 To 3 Set ws = getSheet(sName, wbGrade(iGradeBook)) If Not ws Is Nothing Then ws.Copy after:=.Worksheets(.Worksheets.Count) ' Recopy cells longer than 255 Dim c As Range For Each c In ws.UsedRange.Cells If Len(c.Text) > 255 Then .Worksheets(.Worksheets.Count).Cells(c.Row, c.Column).FormulaR1C1 = c.Text End If Next c End If Next iGradeBook Application.DisplayAlerts = False .Worksheets("Sample").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True .SaveAs sName & sSuffix .Close End With Next iStudent 'Close GradeBooks For iGradeBook = LBound(wbGrade) To UBound(wbGrade) wbGrade(iGradeBook).Close savechanges:=False Next iGradeBook pressedCancel: End Sub Private Sub collectNames(wb As Workbook, cStudents As Collection) Dim ws As Worksheet, s As String For Each ws In wb.Worksheets s = Left(ws.Name, Len(ws.Name) - 2) On Error Resume Next 'skip duplicate names cStudents.Add Item:=s, key:=s On Error GoTo 0 Next ws End Sub Private Function getSheet(sName As String, wb As Workbook) As Worksheet Dim ws As Worksheet, s As String For Each ws In wb.Worksheets s = Left(ws.Name, Len(ws.Name) - 2) If s = sName Then Set getSheet = ws Exit Function End If Next ws Set getSheet = Nothing ' if not found End Function
-
WSSammyB
AskWoody LoungerNovember 13, 2005 at 12:42 am #984785Attached is the student gradebook template. It was created from the teacher’s gradebook with the macro modules deleted, all but one worksheet deleted, and the remaing worksheet renamed to Sample. Actually, I had to delete all of your worksheets and insert a blank one to meet the Lounge filesize requirements. Now I see why you provided a link. And now, a final glitch: I cannot attach a .xlt, so I have renamed it to Student.xls. You will need to rename it back to Student.xlt.
-
-
-
-
-
WSHansV
AskWoody Lounger -
WSjolas
AskWoody LoungerNovember 13, 2005 at 11:52 am #984839I’ve posted the sample workbooks that needs to be process. The worksheets contained in the workbooks have many merged cells with a lot of text. Something that would not be easily exported without the text being truncated in the resulting workbook. SammyB posted an updated code contained in an excel file that I should run the macro from. It should have the workaround to have the text completely transported. When ran it’ll ask me to point to the location of the 3 workbooks to get the data from so initially there’s really no Student.xlt in the picture. Could the Student.xlt file be an interim dynamically generated temporary file to host the captured text from the 3 workbooks to generate the resultant workbooks?
Could this be a loop problem because in the process the 3 workbooks will be open in read-only mode and will start to generate the first resultant workbook until the macro halts in debug mode I guess losing track of the location of the Student.xlt file to continue the loop?
-
WSHansV
AskWoody Lounger -
WSSammyB
AskWoody LoungerNovember 13, 2005 at 2:10 pm #984853As Hans says, you need to either generate Student.xlt from a real teacher gradebook using my instructions or download Student.xls and rename it Student.xlt. Even though Student.xlt has no data, it does have all of the print settings and is used by my macro as the basis for each student grade report. HTH –Sam
-
WSjolas
AskWoody LoungerNovember 14, 2005 at 12:07 am #984922Now it’s clear that I should have the source gradebook workbooks, your macro workbook and the Student.xlt template with a sheet called Sample whose print settings is pattern after the original gradebook in the same folder. Extremely glad when it comes together!!
Now for the real test. Got to go back 4 years of gradebooks and start “breakin and managin” Really appreciate it SammyB!!!
There’s really more than one way to skin a cat and I’m still very much interested in the code from Legare’s perspective.
Regards
jolas
-
-
-
Viewing 1 reply thread -

Plus Membership
Donations from Plus members keep this site going. You can identify the people who support AskWoody by the Plus badge on their avatars.
AskWoody Plus members not only get access to all of the contents of this site -- including Susan Bradley's frequently updated Patch Watch listing -- they also receive weekly AskWoody Plus Newsletters (formerly Windows Secrets Newsletter) and AskWoody Plus Alerts, emails when there are important breaking developments.
Get Plus!
Welcome to our unique respite from the madness.
It's easy to post questions about Windows 11, Windows 10, Win8.1, Win7, Surface, Office, or browse through our Forums. Post anonymously or register for greater privileges. Keep it civil, please: Decorous Lounge rules strictly enforced. Questions? Contact Customer Support.
Search Newsletters
Search Forums
View the Forum
Search for Topics
Recent Topics
-
Chrome Can Now Change Your Weak Passwords for You
by
Alex5723
57 minutes ago -
Microsoft: Over 394,000 Windows PCs infected by Lumma malware, affects Chrome..
by
Alex5723
2 hours, 4 minutes ago -
Signal vs Microsoft’s Recall ; By Default, Signal Doesn’t Recall
by
Alex5723
2 hours, 15 minutes ago -
Internet Archive : This is where all of The Internet is stored
by
Alex5723
2 hours, 28 minutes ago -
iPhone 7 Plus and the iPhone 8 on Vantage list
by
Alex5723
2 hours, 33 minutes ago -
Lumma malware takedown
by
EyesOnWindows
9 hours, 47 minutes ago -
“kill switches” found in Chinese made power inverters
by
Alex5723
11 hours, 21 minutes ago -
Windows 11 – InControl vs pausing Windows updates
by
Kathy Stevens
11 hours, 15 minutes ago -
Meet Gemini in Chrome
by
Alex5723
15 hours, 20 minutes ago -
DuckDuckGo’s Duck.ai added GPT-4o mini
by
Alex5723
15 hours, 29 minutes ago -
Trump signs Take It Down Act
by
Alex5723
23 hours, 28 minutes ago -
Do you have a maintenance window?
by
Susan Bradley
10 hours, 37 minutes ago -
Freshly discovered bug in OpenPGP.js undermines whole point of encrypted comms
by
Nibbled To Death By Ducks
1 hour, 40 minutes ago -
Cox Communications and Charter Communications to merge
by
not so anon
1 day, 2 hours ago -
Help with WD usb driver on Windows 11
by
Tex265
1 day, 7 hours ago -
hibernate activation
by
e_belmont
1 day, 11 hours ago -
Red Hat Enterprise Linux 10 with AI assistant
by
Alex5723
1 day, 15 hours ago -
Windows 11 Insider Preview build 26200.5603 released to DEV
by
joep517
1 day, 18 hours ago -
Windows 11 Insider Preview build 26120.4151 (24H2) released to BETA
by
joep517
1 day, 18 hours ago -
Fixing Windows 24H2 failed KB5058411 install
by
Alex5723
14 hours, 41 minutes ago -
Out of band for Windows 10
by
Susan Bradley
1 day, 23 hours ago -
Giving UniGetUi a test run.
by
RetiredGeek
2 days, 6 hours ago -
Windows 11 Insider Preview Build 26100.4188 (24H2) released to Release Preview
by
joep517
2 days, 13 hours ago -
Microsoft is now putting quantum encryption in Windows builds
by
Alex5723
9 hours, 41 minutes ago -
Auto Time Zone Adjustment
by
wadeer
2 days, 18 hours ago -
To download Win 11 Pro 23H2 ISO.
by
Eddieloh
2 days, 16 hours ago -
Manage your browsing experience with Edge
by
Mary Branscombe
15 hours, 32 minutes ago -
Fewer vulnerabilities, larger updates
by
Susan Bradley
1 day, 9 hours ago -
Hobbies — There’s free software for that!
by
Deanna McElveen
9 hours, 10 minutes ago -
Apps included with macOS
by
Will Fastie
1 day, 13 hours ago
Recent blog posts
Key Links
Want to Advertise in the free newsletter? How about a gift subscription in honor of a birthday? Send an email to sb@askwoody.com to ask how.
Mastodon profile for DefConPatch
Mastodon profile for AskWoody
Home • About • FAQ • Posts & Privacy • Forums • My Account
Register • Free Newsletter • Plus Membership • Gift Certificates • MS-DEFCON Alerts
Copyright ©2004-2025 by AskWoody Tech LLC. All Rights Reserved.