Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1224to1228
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

@ FCS Hilfe bei Codeanpassung

@ FCS Hilfe bei Codeanpassung
Maris
Hi Fcs,
kann den alten Thread leider nicht öffnen. die Anpassung des Bereichs habe ich hinbekommen... Ist das so richtig (funktioniert wenigsten ;-)!):

Dim arrItems(1 To 24)
If iWeek = "99" Then
arrWeeks = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sheets(arrSheets(0)). _
Range("B2:AAA2"))) 'anpassen
Else
arrWeeks = Array(iWeek)
End If
For Each myWeek In arrWeeks
For Each mySheet In arrSheets
With Sheets(mySheet)
lngC = Application.Match(myWeek, .Rows(2), 0)
If Not IsError(lngC) Then
'Kategoriedaten einlesen
For lngRow = 20 To .Cells(Rows.count, 1).End(xlUp).Row Step 17
j = 0
arrTmp = Split(.Cells(lngRow, 1), ">")
j = j + 1: arrItems(j) = myWeek
j = j + 1: arrItems(j) = arrTmp(0) 'Top Level
j = j + 1
If UBound(arrTmp) > 0 Then
arrItems(j) = arrTmp(1) 'Kategorie
End If
j = j + 1: arrItems(j) = .Cells(lngRow, 1) 'Top Level > Kategorie
 For i = 1 To 20
Select Case i
Case 1 To 20
j = j + 1: arrItems(j) = .Cells(lngRow + i, lngC)
End Select
Next
oDaten(.Cells(lngRow, 1).Value & "_" & myWeek) = arrItems
Next
End If
End With
Next
Next myWeek
Application.ScreenUpdating = False
With Sheets("TotalsRaw")
If iWeek = "99" Then
If .Cells(.Rows.count, 1).End(xlUp).Row > 1 Then
.Range(.Cells(2, 1), .Cells(.Rows.count, 1).End(xlUp)).EntireRow.ClearContents
End If
If oDaten.count > 0 Then
 .Cells(Rows.count, 1).End(xlUp).Offset(1).Resize(oDaten.count, 20) = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(oDaten.items))
'KW und Jahr in 2 Spalten aufteilen - für Sortierungen und anderes
With .Range(.Cells(2, 1), .Cells(.Rows.count, 1).End(xlUp))
'          .TextToColumns Destination:=Range("Q2"), DataType:=xlDelimited, _
other:=True, otherchar:="/"
End With
End If
Else
If oDaten.count > 0 Then
lngRow = .Cells(Rows.count, 1).End(xlUp).Row + 1
  .Cells(Rows.count, 1).End(xlUp).Offset(1).Resize(oDaten.count, 20) = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(oDaten.items))
'KW und Jahr in 2 Spalten aufteilen - für Sortierungen und anderes
With .Range(.Cells(lngRow, 1), .Cells(.Rows.count, 1).End(xlUp))
'          .TextToColumns Destination:=Range("Q2"), DataType:=xlDelimited, _
other:=True, otherchar:="/"
End With
End If
End If
End With
Application.ScreenUpdating = True
End Sub
Kannst du mir noch kurz diese Frage beantworten?
https://www.herber.de/forum/archiv/1224to1228/t1225515.htm#1226250
Danke und Viele Grüsse,
Maris

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: @ FCS Hilfe bei Codeanpassung
17.08.2011 20:51:56
fcs
Hallo Maris,
da du insgesamt nur 20 Spalten mit Daten füllen willst sollten folgenden Anpassungen auch noch korrekt sein:
Dim arrItems(1 To 20)
For i = 1 To 16
Select Case i
Case 1 To 16
j = j + 1: arrItems(j) = .Cells(lngRow + i, lngC)
End Select
Next

Zu deinen Fragen:
ich habe gesehen, das der Code falls etwas nicht vorhanden ist selbständig kopiert... verstehe aber die Logik nicht...
Was ist das Problem bei der Logik?
Am Beginn der Schleife werden Hauptkategorie und Mainkategories (Sub-Kategorie) in Variablen eingelesen:
      sKategorie = .Cells(Zeile, 1).Text
sSubKategorie = .Cells(Zeile, 2).Text

sKategorie ist dann der Blattname des Tabellenblattes (Auto oder Motorräder) in das die Rohdaten eingetragen werden.
Danach wird in Zeile 2 dann die Zelle gesucht bzw. die Spalte ermittelt, in der die Kalenderwoche steht.
        'Spalte mit KW suchen
Set rZelle = .Rows(2).Find(what:=iWeek, lookat:=xlWhole, LookIn:=xlValues)
Falls die KW nicht gefunden wird, dann wird nach Rückfrage eine neue Spalte mit für Daten kopiert.
In ähnlicher Weise wird danach in Spalte A ab Zeile 18 abwärts die Zelle gesucht bzw. die Zeile ermittelt, in der die Sub-Kategorie steht.
        'Sub-Kategorie suchen
Set rZelle = .Range(.Cells(18, 1), .Cells(.Rows.Count, 1).End(xlUp)) _
.Find(what:=sSubKategorie, lookat:=xlWhole, LookIn:=xlValues)
Wird keine Zelle gefunden, dann wird ein kompletter Zeilenblock kopiert und vorhandene Daten im Block gelöscht.
Ein Prüfung, ob ein Blatt mit der Hauptkategorie (Auto oder Motorräder) vorhanden ist erfolgt bisher nicht. Ich bin davon ausgegangen, das in den Rohdaten nur diese beiden Kategorien vorkommen.
Im hochgeladenen Textfile hab ich entsprechende Prüfungen und Meldungen für Kategorie und Subkategorie in "prcDatenEintragen" eingebaut, teilweise mit Entscheidung was gemacht werden soll.
https://www.herber.de/bbs/user/76230.txt
Gruß
Franz
Anzeige
AW: @ FCS Hilfe bei Codeanpassung
18.08.2011 09:50:11
Maris
Für mich war es halt immer hilfreichen Wenn ich von den Rohdatenblättern in die einzelen Kategorien kopiert habe und eine Subkategorie nicht existiert hat oder ein Tabellenblatt das dann ein Meldung kam das die Subkategorie oder Tabellenblatt nicht existiert und das wurde dann Rot eingefärbt in den Rohdaten... so konnte ich es anlegen und den export dann nochmal machen...
Wie es jetzt verstanden habe prüft der Code das Vorhandensein und falls nicht wird die Unterkategorieangelegt und/oder die Spalte mit der Kalenderwoche auch, richtig?
In den Zellen der Unterkategorie stehen ja teilweise auch Formeln, werden die auch berücksichtigt?
Ich teste mal deinen neuen Code.
Vielen lieben dank schon mal!
Grüßle,
Maris
Anzeige
Wahnsinn
18.08.2011 17:15:39
Maris
Dein Code ist der Hammer! Er prüft alles überträgt alles inkl. Formel... Ich bin einfach nur begeistert!
DankE!
FCS

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige