• Make Break Recombine (Excel 2002)

    Author
    Topic
    #426227

    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.

    Viewing 1 reply thread
    Author
    Replies
    • #984353

      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.

      • #984471

        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

        • #984506

          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

          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
          
        • #984509

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


          strPath = "C:Work123"
          [/code

          to 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

          • #984694

            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

            • #984709

              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.


              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

            • #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.

            • #984792

              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.

            • #984794

              ouch Nothing 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

            • #984797

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

              Thanks again ymmas! wink

            • #984809

              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”)

            • #984819

              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.

            • #984783

              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

              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
              
            • #984785

              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.

    • #984821

      But where did you store the Student.xlt file? If you haven’t downloaded it, Sammy’s macro won’t be able to find it.

      • #984839

        I’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?

        • #984841

          I’ll leave this for Sammy to answer.

        • #984853

          As 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

          • #984922

            Now 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 smile

    Viewing 1 reply thread
    Reply To: Make Break Recombine (Excel 2002)

    You can use BBCodes to format your content.
    Your account can't use all available BBCodes, they will be stripped before saving.

    Your information: