saving splitted data into different worksheets/ workbooks

S

Ste^phaan

New member
Joined
Oct 5, 2014
Messages
7
Reaction score
0
Points
0
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: 
[COLOR=#333333]Dim a, it, i%, i1%, arr, sSectie$, sWB$, sC10$, splits, ssupervisor$, slocation$, sLocNEW$, MyKeys, sh As Worksheet, sLocWbC10$, MyKeysF, WB As Workbook, splits2[/COLOR]
  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 [FONT=Verdana]End Sub[/FONT][/code
+]
 

Attachments

  • testworksheetsplittabsxlsx.xlsm
    24.9 KB · Views: 25
Last edited:
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?
 
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
 
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?
 
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
          [B]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[/B]
          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
 
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.
 
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.
 
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:
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:
Lees jij de PM's in dit forum niet ?

See the attachment.
 

Attachments

  • __split sheet snb.xlsb
    25.1 KB · Views: 14
what do you mean by PM? I've read the faq ans rules and try to apply them.
I've tested __splitsheetsnb file but I can only see a sorted table in location 1 and 2 that has been added as a result of the snb sub. It seems that it is not a solution for my problem.
the other macro generates an error 400 without any further information
 
If you have no idea about VBA at all you are only looking for a solution.
In that case you'd better hire a programmer.
 
I tried to solve it using formulas but I found out that it would be too heavy and took to many resources from the system. I started to follow a vba course recently and realised that the level of experience needed to make something decent looking was out of my league at the moment. Therefore I posted this request 1. to get a solution and 2. to learn from what was offered.
 
You must log in or register to reply here.
Back
Top