Thema Datum  Von Nutzer Rating
Antwort
30.12.2012 21:32:41 timi
Solved
31.12.2012 19:05:29 Trägheit
NotSolved
01.01.2013 20:33:35 Gast42162
NotSolved
01.01.2013 21:02:54 Gast47955
NotSolved
01.01.2013 21:20:56 Gast86138
NotSolved
02.01.2013 01:15:50 timi
NotSolved
Rot Dringend Hilfe mit der Umformatierung der Daten
02.01.2013 11:31:16 Trägheit
NotSolved
02.01.2013 23:14:17 timi
NotSolved
02.01.2013 23:20:59 timi
NotSolved
03.01.2013 14:02:37 Gast6953
NotSolved
03.01.2013 15:01:58 timi
NotSolved
03.01.2013 14:57:02 Trägheit
NotSolved
03.01.2013 15:10:18 timi
NotSolved
03.01.2013 15:29:29 Gast38708
NotSolved
03.01.2013 15:39:36 timi
NotSolved
03.01.2013 16:09:25 Gast87080
NotSolved
03.01.2013 16:28:22 timi
NotSolved
03.01.2013 22:16:00 Trägheit
NotSolved
03.01.2013 23:50:02 timi
NotSolved
04.01.2013 14:35:53 Gast69606
NotSolved
04.01.2013 15:13:57 timi
NotSolved
04.01.2013 18:47:41 Trägheit
NotSolved
04.01.2013 19:17:00 timi
NotSolved
05.01.2013 06:47:18 Trägheit
Solved
05.01.2013 11:03:27 timi
NotSolved
05.01.2013 18:05:58 Trägheit
NotSolved
05.01.2013 18:22:01 timi
NotSolved
05.01.2013 13:43:31 alex
NotSolved
05.01.2013 20:46:23 Trägheit
NotSolved
06.01.2013 00:59:12 alex
NotSolved
06.01.2013 15:12:10 Gast47772
NotSolved
06.01.2013 15:45:40 alex
NotSolved
07.01.2013 19:06:01 Gast50417
NotSolved
03.01.2013 23:56:30 timi
NotSolved

Ansicht des Beitrags:
Von:
Trägheit
Datum:
02.01.2013 11:31:16
Views:
1349
Rating: Antwort:
  Ja
Thema:
Dringend Hilfe mit der Umformatierung der Daten

Damit dürfte es nun laufen:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
Option Explicit
 
Private Type tRecord
  Name    As String
  Value   As Variant
  Format  As String
End Type
 
Private Type tRecordset
  Record() As tRecord
  Count As Long
End Type
 
Sub TestIt()
   
  transpRecordsets Worksheets("Page 1"), Worksheets("Sheet1")
   
End Sub
  
Public Sub transpRecordsets(Source As Excel.Worksheet, Destination As Excel.Worksheet)
   
  Destination.UsedRange.Clear
   
  Application.ScreenUpdating = False
   
  Dim rng As Excel.Range
  Dim rs  As tRecordset
  Dim result&, rid&, n&, i&
  Dim bCopyHeader As Boolean
  Dim bExit As Boolean
   
  bCopyHeader = True
  rid = 2
   
  Set rng = Source.Range("B2")
   
  While Not bExit
     
    result = GetNextRecordset(rng, rs)
     
    If result = 1 Then
       
      For i = 1 To rs.Count
         
        'einmalig Kopfzeile ausfüllen
        If rid > 1 And bCopyHeader Then
          With Destination.Cells(rid - 1, i)
            .Font.Bold = True
            .Value = rs.Record(i).Name
            .WrapText = False
          End With
        End If
         
        'Daten in die Zeile schreiben
        With Destination.Cells(rid, i)
          .NumberFormat = rs.Record(i).Format
          .Value = rs.Record(i).Value
          .WrapText = False
        End With
         
      Next
       
      bCopyHeader = False
       
      rid = rid + 1
      n = n + 1
       
    Else
      bExit = True
    End If
     
  Wend
   
  Application.ScreenUpdating = True
   
  If result <> -1 Then
     
    If n <> 1 Then
      Call MsgBox("Es wurden " & n & " Datensätze kopiert.", vbInformation)
    Else
      Call MsgBox("Es wurde 1 Datensatz kopiert.", vbInformation)
    End If
     
  Else
    Call MsgBox("Datensätze konnten nicht alle verarbeitet werden " & vbNewLine & "(" & n & " DS kopiert).", _
              vbExclamation)
  End If
   
End Sub
 
Private Function GetNextRecordset(Ref As Excel.Range, Recordset As tRecordset) As Long
   
  'eine Leerzeile überspringen ist erlaubt
  If Len(Trim(Ref.Cells(1).Text)) = 0 Then
    Set Ref = Ref.Offset(RowOffset:=1)
  End If
   
  'Anfang Datensatz (DS)?
  If Len(Trim(Ref.Cells(1).Text)) > 0 Then
     
    Dim c           As Excel.Range
    Dim rs          As tRecordset
    Dim bRecord     As Boolean
    Dim bAdd2Prev   As Boolean
     
    bRecord = Len(Trim(Ref.Offset(ColumnOffset:=1).Cells(1).Text)) > 0
    While bRecord
       
      If rs.Count > 0 And Len(Trim(Ref.Cells(1).Text)) > 0 Then
      'PROBLEM:
      'Angeblich neuer DS erkannt, ohne das der
      'aktuelle DS mit Leerzeile abgeschlossen wurde
         
        rs.Count = 0
        Erase rs.Record
         
        GetNextRecordset = -1
        Exit Function
         
      'Name mit nur einem Wert?
      ElseIf Len(Trim(Ref.Offset(ColumnOffset:=1).Cells(1).Text)) > 0 _
              And Not Ref.Offset(ColumnOffset:=1).MergeCells Then
        bAdd2Prev = False
         
      'Name mit mehreren Werten?
      ElseIf Len(Trim(Ref.Offset(ColumnOffset:=1).Cells(1).Text)) > 0 _
              And Ref.Offset(ColumnOffset:=1).MergeCells Then
        bAdd2Prev = True
         
      Else
        bRecord = False
      End If
       
      If bRecord Then
         
        rs.Count = rs.Count + 1
        ReDim Preserve rs.Record(1 To rs.Count)
         
        With rs.Record(rs.Count)
          .Name = Ref.Offset(ColumnOffset:=1).Cells(1).Text
           
          If Not bAdd2Prev Then
            .Value = Ref.Offset(ColumnOffset:=2).Cells(1).Value
          Else
            For Each c In Ref.Offset(ColumnOffset:=2).Resize(Ref.Offset(ColumnOffset:=1).MergeArea.Rows.Count, 1).Cells
              .Value = .Value & IIf(Not IsEmpty(.Value), vbNewLine, "") & c.Value
            Next
          End If
           
          .Format = Ref.Offset(ColumnOffset:=2).Cells(1).NumberFormat
        End With
         
        'nächster Eintrag
        Set Ref = Ref.Offset(RowOffset:=1)
      End If
       
    Wend
     
    Recordset = rs
     
    rs.Count = 0
    Erase rs.Record
     
    'Rückgabe
    GetNextRecordset = 1
  Else
    'Rückgabe
    'GetNextRecordset = 0
  End If
   
End Function

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
30.12.2012 21:32:41 timi
Solved
31.12.2012 19:05:29 Trägheit
NotSolved
01.01.2013 20:33:35 Gast42162
NotSolved
01.01.2013 21:02:54 Gast47955
NotSolved
01.01.2013 21:20:56 Gast86138
NotSolved
02.01.2013 01:15:50 timi
NotSolved
Rot Dringend Hilfe mit der Umformatierung der Daten
02.01.2013 11:31:16 Trägheit
NotSolved
02.01.2013 23:14:17 timi
NotSolved
02.01.2013 23:20:59 timi
NotSolved
03.01.2013 14:02:37 Gast6953
NotSolved
03.01.2013 15:01:58 timi
NotSolved
03.01.2013 14:57:02 Trägheit
NotSolved
03.01.2013 15:10:18 timi
NotSolved
03.01.2013 15:29:29 Gast38708
NotSolved
03.01.2013 15:39:36 timi
NotSolved
03.01.2013 16:09:25 Gast87080
NotSolved
03.01.2013 16:28:22 timi
NotSolved
03.01.2013 22:16:00 Trägheit
NotSolved
03.01.2013 23:50:02 timi
NotSolved
04.01.2013 14:35:53 Gast69606
NotSolved
04.01.2013 15:13:57 timi
NotSolved
04.01.2013 18:47:41 Trägheit
NotSolved
04.01.2013 19:17:00 timi
NotSolved
05.01.2013 06:47:18 Trägheit
Solved
05.01.2013 11:03:27 timi
NotSolved
05.01.2013 18:05:58 Trägheit
NotSolved
05.01.2013 18:22:01 timi
NotSolved
05.01.2013 13:43:31 alex
NotSolved
05.01.2013 20:46:23 Trägheit
NotSolved
06.01.2013 00:59:12 alex
NotSolved
06.01.2013 15:12:10 Gast47772
NotSolved
06.01.2013 15:45:40 alex
NotSolved
07.01.2013 19:06:01 Gast50417
NotSolved
03.01.2013 23:56:30 timi
NotSolved