Page 1 of 2 12 LastLast
Results 1 to 15 of 20
  1. #1
    3 Star Lounger
    Join Date
    Feb 2001
    Location
    Tokyo, Japan
    Posts
    203
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Make Break Recombine (Excel 2002)

    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.

  2. #2
    Uranium Lounger
    Join Date
    Jan 2001
    Location
    South Carolina, USA
    Posts
    7,295
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Make Break Recombine (Excel 2002)

    This 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.
    Legare Coleman

  3. #3
    3 Star Lounger
    Join Date
    Feb 2001
    Location
    Tokyo, Japan
    Posts
    203
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Make Break Recombine (Excel 2002)

    Here 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

  4. #4
    Silver Lounger
    Join Date
    Mar 2001
    Location
    Springfield, Ohio, USA
    Posts
    2,136
    Thanks
    0
    Thanked 1 Time in 1 Post

    Re: Make Break Recombine (Excel 2002)

    If 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
    <pre>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
    </pre>

    <font face="Comic Sans MS">Sam Barrett, CACI </font face=comic>
    <small>And the things that you have heard... commit these to faithful men who will be able to teach others also. 2 Timothy 2:2</small>

  5. #5
    Uranium Lounger
    Join Date
    Jan 2001
    Location
    South Carolina, USA
    Posts
    7,295
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Make Break Recombine (Excel 2002)

    Does this code do what you want? Put the code in a separate workbook and change the line:

    <code>
    strPath = "C:Work123"
    [/code

    to point to the directory where the files are located. The code assumes that none of the individual files exists.

    [code]
    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.Wo rksheets.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
    </code>
    Legare Coleman

  6. #6
    3 Star Lounger
    Join Date
    Feb 2001
    Location
    Tokyo, Japan
    Posts
    203
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Make Break Recombine (Excel 2002)

    Thanks 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

  7. #7
    Uranium Lounger
    Join Date
    Jan 2001
    Location
    South Carolina, USA
    Posts
    7,295
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Make Break Recombine (Excel 2002)

    Here 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.

    <code>
    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.Wo rksheets.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
    </code>
    Legare Coleman

  8. #8
    Silver Lounger
    Join Date
    Mar 2001
    Location
    Springfield, Ohio, USA
    Posts
    2,136
    Thanks
    0
    Thanked 1 Time in 1 Post

    Re: Make Break Recombine (Excel 2002)

    > 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.
    <font face="Comic Sans MS">Sam Barrett, CACI </font face=comic>
    <small>And the things that you have heard... commit these to faithful men who will be able to teach others also. 2 Timothy 2:2</small>

  9. #9
    Silver Lounger
    Join Date
    Mar 2001
    Location
    Springfield, Ohio, USA
    Posts
    2,136
    Thanks
    0
    Thanked 1 Time in 1 Post

    Re: Make Break Recombine (Excel 2002)

    What 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
    <pre>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
    </pre>

    <font face="Comic Sans MS">Sam Barrett, CACI </font face=comic>
    <small>And the things that you have heard... commit these to faithful men who will be able to teach others also. 2 Timothy 2:2</small>

  10. #10
    Silver Lounger
    Join Date
    Mar 2001
    Location
    Springfield, Ohio, USA
    Posts
    2,136
    Thanks
    0
    Thanked 1 Time in 1 Post

    Re: Make Break Recombine (Excel 2002)

    Attached 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.
    <font face="Comic Sans MS">Sam Barrett, CACI </font face=comic>
    <small>And the things that you have heard... commit these to faithful men who will be able to teach others also. 2 Timothy 2:2</small>

  11. #11
    3 Star Lounger
    Join Date
    Feb 2001
    Location
    Tokyo, Japan
    Posts
    203
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Make Break Recombine (Excel 2002)

    Sammy please download the file here . The print settings maybe summarized from the attachment. Legare if you are around here the bit of info you may need. Thanks again guys! Have a nice weekend.

  12. #12
    Silver Lounger
    Join Date
    Mar 2001
    Location
    Springfield, Ohio, USA
    Posts
    2,136
    Thanks
    0
    Thanked 1 Time in 1 Post

    Re: Make Break Recombine (Excel 2002)

    <img src=/S/ouch.gif border=0 alt=ouch width=15 height=15> Nothing like real data to break your code! But, only one line to change:

    <pre>.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</pre>

    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
    <font face="Comic Sans MS">Sam Barrett, CACI </font face=comic>
    <small>And the things that you have heard... commit these to faithful men who will be able to teach others also. 2 Timothy 2:2</small>

  13. #13
    3 Star Lounger
    Join Date
    Feb 2001
    Location
    Tokyo, Japan
    Posts
    203
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Make Break Recombine (Excel 2002)

    It stopped somewhere where it can't open the Student.xls file. please see attachment.

    Thanks again ymmas! <img src=/S/wink.gif border=0 alt=wink width=15 height=15>

  14. #14
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts

    Re: Make Break Recombine (Excel 2002)

    Have you renamed the Student.xls file SammyB attached to Student.xlt and placed it in the Templates folder or in the default document folder for Excel? If it's in another folder, you must specify the path, for example

    With Workbooks.Add("C:SomeFolderStudent.xlt")

  15. #15
    3 Star Lounger
    Join Date
    Feb 2001
    Location
    Tokyo, Japan
    Posts
    203
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Make Break Recombine (Excel 2002)

    Typo 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.

Page 1 of 2 12 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •