Wegschrijven data

[gelens]

Forumleden

Vanaf een invulsheet probeer ik data weg te schrijven naar het sheet "Data". Hiervoor heb ik onderstaande code bij elkaar gesprokkeld.

sub uitsplitsen()
  Dim bereik As Range, c As Range, tekst As String, splits As Variant
  With Sheets("Budget")
    Set bereik = .Range("scenario")                          'bereik waar gegevens staan
    On Error Resume Next
    Set c = Union(bereik.SpecialCells(xlConstants), bereik.SpecialCells(xlFormulas), bereik.SpecialCells(xlComments))  'alle niet-lege cellen en formules in dat bereik
    If Not c Is Nothing Then
      On Error GoTo 0
      For Each c In Union(bereik.SpecialCells(xlConstants), bereik.SpecialCells(xlFormulas), bereik.SpecialCells(xlComments)).Cells 'loop ieder zulke cel af
        If c.Value <> "" Then                              'cel is niet leeg
         tekst = tekst & .Cells(c.Column, "7").Value & "\" & .Cells("8", c.Column).Value & "\" & .Cells(c.Row, "a").Value & "\" & .Cells(10, c.Column) & "\" & c.Value & "|" 'zet alle gegevens in deze tekst gescheiden met "\" &n "|"
        End If
      Next
    End If
  End With

  With Sheets("Data")
  Application.Goto Reference:="Data_leeg"                   'eerste lege cel
      splits = Split(tekst, "|")                           'splits per record
     .Range("A2").Resize(UBound(splits), 1) = WorksheetFunction.Transpose(splits)  'wegschrijven naar A-kolom
     .Range("A2").Resize(UBound(splits), 1).TextToColumns Destination:=Range("a2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1)), TrailingMinusNumbers:=True 'splits A-kolom verder uit
    
    End If
  End With
End Sub

Helaas lukt het niet om e.e.a. werkend te krijgen. Ik krijg geen foutmelding maar er wordt ook niet weggeschreven.
Heeft iemand een tip ?
Daarnaast zou het mooi zijn als ook de "Opmerkingen" meegenomen worden.

 

[danny147]

Beste gelens

Volgens mij moet je ipv bereik, hier wel degelijk een bereik ingeven.

    Set c = Union(bereik.SpecialCells(xlConstants), bereik.SpecialCells(xlFormulas), bereik.SpecialCells(xlComments))  'alle niet-lege cellen en formules in dat bereik
    If Not c Is Nothing Then

Vb. Moet worden:

Union(range("A1:A10").SpecialCells...enz

De laatste End If mag ook weg.

Groetjes Danny. :thumb:

 

[gelens]

Beste Danny,

Dat bereik had ik gedefinieerd :

Set bereik = .Range("scenario")

Volgens mij gaat het in het volgende stukje code fout :

If Not c Is Nothing Then
      On Error GoTo 0

Zoals ik het begrijp wordt hier gekeken of de cel gevuld is, zoniet dan door naar de volgende cel.
Een aantal cellen zijn wel degelijk gevuld.

Nog een andere tip ??