Page 1 of 2 1 2 LastLast
Results 1 to 10 of 13

Thread: saving splitted data into different worksheets/ workbooks

  1. #1

    saving splitted data into different worksheets/ workbooks



    Register for a FREE account, and/
    or Log in to avoid these ads!

    I have vba-code written for me but as I'm not ver knowledgeable about programming in vba ( I can follow the logic and understand what the code is doing) I cannot program it myself.

    1. how can I make sure that whatever the size of imported data in the original sheet, is set as tabel1

    The code splits up the raw data of a worksheet into different workbooks and/or worksheets depending on the content of certain cells.
    A new workbook has to be made (or added to) whenever a cell in column A has WB: in it (in the attached file there are WB:AWP en WB:BM so there should be a workbook with the naam AWP and one with the name BM.
    Each of these workbooks will contain worksheets that have the name of a location found in column F connectionlocation. The goal is to split the lines in the original worksheet (Sheet2) so that the content of each line is put in the right workbook and the right locationworksheet depending on the connectionlocation in column F.
    The vba code does work this way but whenever it has to add to an already existing worksheet/book there is an error. As far as I have been able to debug the code, it cannot overwrite an exisiting worksheet. As the vba code is quite condensed I could not myself find the right way to insert a sub that would copy the information already in a sheet , add the line that caused the error into the right sheet and continue.
    Any help would be greatly appreciated. If this explanation is not clear enough, I will gladly clarify.
    ps :this problem was also posted on excelforum.com under the same title
    regards
    STephaan


    [code]

    Dim a, it, i%, i1%, arr, sSectie$, sWB$, sC10$, splits, ssupervisor$, slocation$, sLocNEW$, MyKeys, sh As Worksheet, sLocWbC10$, MyKeysF, WB As Workbook, splits2
    With CreateObject("scripting.dictionary") 'create dictionary a = Range("Table1") 'read range into array For i = 1 To UBound(a) 'go through each row of the array If InStr(1, a(i, 1), "Section:", 1) = 1 Then 'does 1rst element start with "Section:" ? sSectie = Mid(a(i, 1), 9) 'new section ElseIf InStr(1, a(i, 1), "WB:", 1) = 1 Then 'same for WB sWB = Mid(a(i, 1), 4) ElseIf InStr(1, a(i, 1), "C10", 1) = 1 Then 'same for C10-type sC10 = a(i, 1) ElseIf InStr(1, a(i, 1), "supervisor:", 1) = 1 Then 'same for supervisor splits = Split(a(i, 1)) If UBound(splits) >= 2 Then ssupervisor = splits(1) slocation = splits(UBound(splits)) End If ElseIf Len(a(i, 1)) Then ' there is something in 1rst element (person) sLocNEW = Trim(a(i, 6)) 'possible wrong location If sLocNEW = "" Then sLocNEW = "Dummy" 'if nog location present, call it dummy If sLocNEW <> slocation Then 'is it a wrong location sLocWbC10 = slocation & "|" & sWB & "|" & sC10 & "|" & sLocNEW 'make a key with location & WB & C10 & new location it = .Item(sLocWbC10) 'check wether ifo present for wrong location If VarType(it) = vbEmpty Then 'if not ReDim arr(1 To UBound(a, 2) + 5, 1 To 1) 'make an empty array to be used later it = arr 'array is now called it Else ReDim Preserve it(1 To UBound(it), 1 To UBound(it, 2) + 1) 'add 1 column to existing array for that wrong location End If it(1, UBound(it, 2)) = sSectie 'fill out several items in 1rst or last added column it(2, UBound(it, 2)) = sWB it(3, UBound(it, 2)) = sC10 it(4, UBound(it, 2)) = ssupervisor it(5, UBound(it, 2)) = slocation For i1 = 1 To UBound(a, 2): it(i1 + 5, UBound(it, 2)) = a(i, i1): Next .Item(sLocWbC10) = it 'write result back to dictionary End If End If Next Application.ScreenUpdating = False If .Count Then 'if there is something in the dictionary, it means certain locations were wrong arr = Array("section", "WB", "C10", "supervisor", "location", "Name", "nr", "Portfolio", "Flux", "form", "Connectionlocation", "Check", "number") ' header MyKeys = .keys 'read the wrong locations in the dictionary-keys Do While UBound(MyKeys) >= 0 'check all keys 1 by 1 Set WB = Workbooks.Add 'add new workbook splits = Split(MyKeys(0), "|") 'split 1rst key still in Mykeys when "|" character is found MyKeysF = Filter(MyKeys, splits(0) & "|" & splits(1) & "|", 1, 1) 'filter in mykeys all keys with same location and WB For i = 0 To UBound(MyKeysF) 'loop through all keys of same location and WB splits2 = Split(MyKeysF(i), "|") ' split the key at every "|" character Set sh = WB.Worksheets.Add ' add new worksheet If sh Is Nothing Then ActiveSheet.Name = sh.Name = splits2(UBound(splits2)) 'if needed adapt name worksheet sh.Name = splits2(UBound(splits2)) 'rename worksheet to last term in in key(i.e. the wrong location) On Error Resume Next 'continue on error sh.Name = Left(splits2(UBound(splits2)), 31) 'rename worksheet to last term in in key(i.e. the wrong location) On Error GoTo 0 it = .Item(MyKeysF(i)) 'get respective array from dictionary sh.Range("A2").Resize(UBound(it, 2), UBound(it)).Value = WorksheetFunction.Transpose(it) 'write array in transposed option sh.Columns("G").NumberFormat = "0" 'layout for column 6 With sh.Range("A1").Resize(, UBound(arr) + 1) 'header .Value = arr 'write .EntireColumn.AutoFit 'adapt column width End With Next MyKeys = Filter(MyKeys, splits(0) & "|" & splits(1) & "|", 0, 1) 'remove all keys of that location and WB from MyKeys Application.DisplayAlerts = False With WB 'is the new workbook just created .SaveAs ThisWorkbook.Path & "\Fouten_" & splits(0) & "WB" & splits(1) .Close False End With Application.DisplayAlerts = True Loop End If End With End Sub[/code
    +]
    Attached Files Attached Files
    Last edited by Ste^phaan; 2014-10-05 at 11:49 AM. Reason: code was not fitted correctly

  2. #2
    Conjurer WizzardOfOz's Avatar
    Join Date
    Sep 2013
    Location
    Australia
    Posts
    184
    Articles
    0
    As clear as mud. Let's see if I follow (using your sample sheet)

    A2: contains section
    A3: contains WB so this block goes into AWP (Question assuming this is the current folder?)
    A4: Contains C10 (whatever that is)
    A5: contains supervisor

    row 6 to row 19 must go to workbook AWP into sheets named location1 to location7 (include section, C10 and supervisor)
    After coping row 6 to 19 must be deleted from sheet 2. (Question what about row 2 to 5)
    Another question person (column) discarded

    Repeat for the rest leaving sheet 2 empty.

    Is this what you want?

  3. #3
    about the folder : I think I can manage to get the folder redirection programmed so for the moment the current folder will do
    rows 2 - 5 can be discarded because row2 section is not important, row 3 the information is written to WB AWP, and row 4 c10 codes are listed in the worksheets in the first column and row5 is contained in the naming of the worksheets

    the lines in each workbook should include following headers (although we can do without the headers)/ columns
    c10-code Name nr portfolio Flux form (connectionlocation optional)

    example from lines 34 - 39 fyi : this information signals us that 4 documents are available for this 1 person but in different physical locations
    splitting up these lines should give 4 worksheets in the workbook AWP

    WS with name location1 containing line
    C10Opv person1 700000000237458 201311 C 220B paper location1

    WS with name location2 containing line
    C10Opv person2 700000000237458 201311 C220B paper location2

    WS with name location3 containing line
    C10Opv person3 700000000237458 201401 C 220B paper location3

    WS with name location7 containing line
    C10Opv person4 700000000237458 201401 C220B paper location7

    thanks for your support
    stephaan

  4. #4
    Magician NoS's Avatar
    Join Date
    Jan 2013
    Location
    British Columbia
    Posts
    675
    Articles
    0
    Excel Version
    Excel 2010 64bit
    If I comment out the 3 lines of code that rename the sheets being added to the new workbook, so the code will run, I see a new sheet is added for each different location in each of the different c10 sections.

    I think this is what your question is about with regards to not using existing sheets, Right?

    Is it intentional that no line from Sheet2 with location1 in column F is included in the new workbook?

  5. #5
    I hope I managed to get the code in a decent form now. Something went wrong in the initial question when I used de code tags.

    @ NOS : do you mean these lines (see text underneath in bold)

    about lines with location1 : yes and no : if the location in column F is equal to the location mentioned in the field supervisor, it means that documents are where they are supposed to be and so the lines could be discarded. But if these lines are generated in the program under the worksheet with that location, it is not a problem.
    When testing with actual data I ran into a problem when adding lines to an already existing worksheet. I'll run it again with these lines commented out.

    regards
    stephaan

    Code:
    Dim a, it, i%, i1%, arr, sSectie$, sWB$, sC10$, splits, ssupervisor$, slocation$, sLocNEW$, MyKeys, sh As Worksheet, sLocWbC10$, MyKeysF, WB As Workbook, splits2
      With CreateObject("scripting.dictionary")                'create dictionary
        a = Range("Table1")                                    'read range into array
        For i = 1 To UBound(a)                                 'go through each row of the array
          If InStr(1, a(i, 1), "Section:", 1) = 1 Then          'does 1rst element start with "Section:" ?
            sSectie = Mid(a(i, 1), 9)                          'new section
          ElseIf InStr(1, a(i, 1), "WB:", 1) = 1 Then          'same for WB
            sWB = Mid(a(i, 1), 4)
          ElseIf InStr(1, a(i, 1), "C10", 1) = 1 Then          'same for C10-type
            sC10 = a(i, 1)
          ElseIf InStr(1, a(i, 1), "supervisor:", 1) = 1 Then   'same for supervisor
            splits = Split(a(i, 1))
            If UBound(splits) >= 2 Then
              ssupervisor = splits(1)
              slocation = splits(UBound(splits))
            End If
          ElseIf Len(a(i, 1)) Then                             ' there is something in 1rst element (person)
            sLocNEW = Trim(a(i, 6))                            'possible wrong location
            If sLocNEW = "" Then sLocNEW = "Dummy"             'if nog location present, call it dummy
            If sLocNEW <> slocation Then                        'is it a wrong location
              sLocWbC10 = slocation & "|" & sWB & "|" & sC10 & "|" & sLocNEW  'make a key with location & WB & C10 & new location
              it = .Item(sLocWbC10)                            'check wether ifo present for wrong location
              If VarType(it) = vbEmpty Then                    'if not
                ReDim arr(1 To UBound(a, 2) + 5, 1 To 1)       'make an empty array to be used later
                it = arr                                       'array is now called it
              Else
                ReDim Preserve it(1 To UBound(it), 1 To UBound(it, 2) + 1)  'add 1 column to existing array for that wrong location
              End If
              it(1, UBound(it, 2)) = sSectie                   'fill out several items in 1rst or last added column
              it(2, UBound(it, 2)) = sWB
              it(3, UBound(it, 2)) = sC10
              it(4, UBound(it, 2)) = ssupervisor
              it(5, UBound(it, 2)) = slocation
              For i1 = 1 To UBound(a, 2): it(i1 + 5, UBound(it, 2)) = a(i, i1): Next
              .Item(sLocWbC10) = it                            'write result back to dictionary
            End If
          End If
        Next
        Application.ScreenUpdating = False
        If .Count Then                                         'if there is something in the dictionary, it means certain locations were wrong
          arr = Array("section", "WB", "C10", "supervisor", "location", "Name", "nr", "Portfolio", "Flux", "form", "Connectionlocation", "Check", "number")  ' header
          MyKeys = .keys                                       'read the wrong locations in the dictionary-keys
          Do While UBound(MyKeys) >= 0                         'check all keys 1 by 1
            Set WB = Workbooks.Add                             'add new workbook
            splits = Split(MyKeys(0), "|")                     'split 1rst key still in Mykeys when  "|" character is found
            MyKeysF = Filter(MyKeys, splits(0) & "|" & splits(1) & "|", 1, 1)  'filter in mykeys all keys with same location and WB
            For i = 0 To UBound(MyKeysF)                       'loop through all keys of same location and WB
              splits2 = Split(MyKeysF(i), "|")                 ' split the key at every "|" character
              Set sh = WB.Worksheets.Add                       ' add new worksheet
              If sh Is Nothing Then ActiveSheet.Name = sh.Name = splits2(UBound(splits2))   'if needed adapt name worksheet
              sh.Name = splits2(UBound(splits2))          'rename worksheet to last term in in key(i.e. the wrong location)
              On Error Resume Next 'continue on error
              sh.Name = Left(splits2(UBound(splits2)), 31)              'rename worksheet to last term in in key(i.e. the wrong location)
              On Error GoTo 0
              it = .Item(MyKeysF(i))                           'get respective array from dictionary
              sh.Range("A2").Resize(UBound(it, 2), UBound(it)).Value = WorksheetFunction.Transpose(it)  'write array in transposed option
              sh.Columns("G").NumberFormat = "0"               'layout for column 6
              With sh.Range("A1").Resize(, UBound(arr) + 1)    'header
                .Value = arr                                   'write
                .EntireColumn.AutoFit                          'adapt column width
              End With
            Next
            MyKeys = Filter(MyKeys, splits(0) & "|" & splits(1) & "|", 0, 1)  'remove all keys of that location and WB from MyKeys
            Application.DisplayAlerts = False
            With WB                                            'is the new workbook just created
              .SaveAs ThisWorkbook.Path & "\Fouten_" & splits(0) & "WB" & splits(1)
              .Close False
            End With
            Application.DisplayAlerts = True
          Loop
        End If
      End With
    End Sub

  6. #6
    Magician NoS's Avatar
    Join Date
    Jan 2013
    Location
    British Columbia
    Posts
    675
    Articles
    0
    Excel Version
    Excel 2010 64bit
    yes, yes and the sh.Name= between the 2 On Error statements

    With VBA there is always more than 1 way to do anything.
    It would be interesting to know what the original request was that got you this code.
    While cryptic arrays may be fast and efficient...... a lot can be said for something easier to follow.

  7. #7
    the original request is as stated above (a bit more extensive as I had to describe what I needed without the benefit of something already porgrammed, but in Dutch, only the person who wrote it is no longer available) . It worked fine with testdata untill I tried it on real data and then found that it got blocked when having to add a line on an already existing worksheet.
    Unless it is a setting or parameter or something active or not active in my excel environment that prevents it from working, but I think that is not the case.

    Can't agree more with your last statement. I'm already happy that I can more or less follow the logic of it.

  8. #8
    Conjurer snb's Avatar
    Join Date
    May 2013
    Posts
    370
    Articles
    0
    Excel Version
    2020
    To make a start:
    remove all groups in Blad2

    Code:
    Sub M_snb()
        With Blad2.Cells(1).CurrentRegion
           For j = 1 To 2
            .AutoFilter 6, "location" & j
            .Offset(1).Copy Sheets("Location" & j).Cells(Sheets("Location" & j).UsedRange.Rows.Count + 2, 1)
            .AutoFilter
           Next
        End With
    End Sub
    The only thing you have to do is add a column A in which the names 'C10wkl' will be assigned to each 'record'
    Last edited by snb; 2014-10-06 at 08:43 PM.

  9. #9
    I' ve tried the above solution (presuming I had to remove all programming that was in the current macro and replacing it with the sub from snb, I did not completely understand which groups to remove). I starts sorting but then I get an out of range error and I doesn't create the workbook/sheets as we would like it to do.
    Maybe I tested it the wrong way?

    Stephaan
    Last edited by Ste^phaan; 2014-10-07 at 07:49 AM.

  10. #10
    Conjurer snb's Avatar
    Join Date
    May 2013
    Posts
    370
    Articles
    0
    Excel Version
    2020
    Lees jij de PM's in dit forum niet ?

    See the attachment.
    Attached Files Attached Files

Page 1 of 2 1 2 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
  •