Datenimport

Hallo liebe Leute,
ich brauch dringend hilfe bei der Umsetzung eine Imports von Daten... jeglicher Versuch das mit Formeln zu machen ist leider gescheitert (Performancegründen), deswegen meine letzte Hoffnung vielleicht das mit VBA umzusetzen. Anbei auch die Beispieldatei.
Ich habe x Tabellenblätter die spezifisch der Cod nur zugreifen soll... im Beispiel Auto & Motorräder und Bürobedarf. Die Daten sind nach KW sortiert. In den Tabs immer in Zeile 3. Ab Zeile 20 beginnen die sog. Kategorien mit den Daten. Jede Kategorie hat Kennzahlen die in das Tabellenblatt TotalsRaw kopiert werden sollen. Auch sind die Kalenderwochen jedoch anders sortiert In Spalte A angegeben und die Kennzahlen in Zeile 1. wäre es möglich das man für das kopieren einen Code verwendet der die Daten in Tab TotalsRaw kopiert? Am besten entweder nur eine bestimmte KW oder alle gleichzeitig.
Wär echt der kanller wenn mir jemand helfen würde!!!!
Lg,
Maris
https://www.herber.de/bbs/user/74488.xls

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Sub prcStart() Dim iWeek iWeek = Application.InputBox("Woche?", "Eingabe", , , , , , 1) Select Case iWeek Case False, "", 0 Case Else: prcDaten iWeek End Select End Sub Sub prcDaten(ByVal iWeek As Integer) Dim oDaten As Object, iRow As Long, iSheet As Integer, lngC, i As Integer Dim arrItems(1 To 20) Set oDaten = CreateObject("Scripting.Dictionary") For iSheet = 2 To Worksheets.Count With Sheets(iSheet) lngC = Application.Match(iWeek, .Rows(2), 0) If Not IsError(lngC) Then For iRow = 20 To .Cells(Rows.Count, 1).End(xlUp).Row Step 17 arrItems(1) = iWeek arrItems(2) = Split(.Cells(iRow, 1), ">")(0) arrItems(3) = Split(.Cells(iRow, 1), ">")(1) arrItems(4) = .Cells(iRow, 1) For i = 5 To 20 arrItems(i) = .Cells(iRow + i - 4, lngC) Next oDaten(.Cells(iRow, 1).Value) = arrItems Erase arrItems Next End If End With Next If oDaten.Count > 0 Then With Sheets("TotalsRaw") .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(oDaten.Count, 20) = _ WorksheetFunction.Transpose(WorksheetFunction.Transpose(oDaten.items)) End With End If End Sub

Hallo,
verstehe ich nicht.
Hier für einzelne oder alle Wochen und ausgewählte Blätter, alle wenn TotalsRaw aktiv ist.

Option Explicit
Sub prcStart()
Dim iWeek
iWeek = Application.InputBox("Woche?" & vbLf & "99 für alle Wochen", "Eingabe", , , , , , 1)
Select Case iWeek
Case False
Case 1 To 53, 99: prcDaten iWeek
End Select
End Sub
Sub prcDaten(ByVal iWeek As Integer)
Dim oDaten As Object, iRow As Long, mySheet, lngC, i As Integer
Dim arrItems(1 To 20), arrWeeks, myWeek, arrTmp, arrSheets, sh, n As Integer
Set oDaten = CreateObject("Scripting.Dictionary")
If iWeek = 99 Then
arrWeeks = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sheets(2).Range("B2:BA2")))
Else
arrWeeks = Array(iWeek)
End If
If LCase(ActiveSheet.Name)  "totalsraw" Then
ReDim arrSheets(0 To ActiveWindow.SelectedSheets.Count - 1)
For Each sh In ActiveWindow.SelectedSheets
arrSheets(n) = sh.Name
n = n + 1
Next
Else
ReDim arrSheets(0 To Worksheets.Count - 2)
For n = 2 To Worksheets.Count
arrSheets(n - 2) = Worksheets(n).Name
Next
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
For iRow = 20 To .Cells(Rows.Count, 1).End(xlUp).Row Step 17
arrTmp = Split(.Cells(iRow, 1), ">")
arrItems(1) = myWeek
arrItems(2) = arrTmp(0)
If UBound(arrTmp) > 0 Then
arrItems(3) = arrTmp(1)
End If
arrItems(4) = .Cells(iRow, 1)
For i = 5 To 20
arrItems(i) = .Cells(iRow + i - 4, lngC)
Next
oDaten(.Cells(iRow, 1).Value & "_" & myWeek) = arrItems
Next
End If
End With
Next
Next myWeek
If oDaten.Count > 0 Then
Application.ScreenUpdating = False
With Sheets("TotalsRaw")
.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(oDaten.Count, 20) = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(oDaten.items))
End With
End If
End Sub

Gruß
Rudi

Hallo Rudi, der Code ist super... vielen lieben Dank :-D! Er bringt mir auch keine _ Fehlermeldung mehr... sehr seltsam ist das er mir in KW 28,8,10,11,13 die ">" nicht erkennt bei allen anderen aber schon.... er schreibt mir bei diesen KW alles was hinter dem ">" kommt aber in die Datentabelle? Irgendeine Erklärung dafür? vielen Dank nochmal und Gruß, Maris

Sub prcDaten(ByVal iWeek As Integer) Dim oDaten As Object, lngRow As Long, lngC, arrSheets, mySheet Dim arrItems(1 To 20), arrWeeks, myWeek, arrTmp, i As Integer, n As Integer Set oDaten = CreateObject("Scripting.Dictionary") If iWeek = 99 Then arrWeeks = _ WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sheets(2).Range("B2:BA2"))) Else arrWeeks = Array(iWeek) End If arrSheets = Array("Auto & Verkehr", "Bürobedarf") 'nach Bedarf erweitern 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 For lngRow = 20 To .Cells(Rows.Count, 1).End(xlUp).Row Step 17 arrTmp = Split(.Cells(lngRow, 1), ">") arrItems(1) = myWeek arrItems(2) = arrTmp(0) If UBound(arrTmp) > 0 Then arrItems(3) = arrTmp(1) End If arrItems(4) = .Cells(lngRow, 1) For i = 5 To 20 arrItems(i) = .Cells(lngRow + i - 4, lngC) Next oDaten(.Cells(lngRow, 1).Value & "_" & myWeek) = arrItems Next End If End With Next Next myWeek If oDaten.Count > 0 Then Application.ScreenUpdating = False With Sheets("TotalsRaw") .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(oDaten.Count, 20) = _ WorksheetFunction.Transpose(WorksheetFunction.Transpose(oDaten.items)) End With End If End Sub

Sub prcDaten(ByVal iWeek As Integer) Dim oDaten As Object, lngRow As Long, lngC, arrSheets, mySheet Dim arrItems(1 To 20), arrWeeks, myWeek, arrTmp, i As Integer Set oDaten = CreateObject("Scripting.Dictionary") arrSheets = Array("Auto & Motorräder", "Büro") 'nach Bedarf erweitern If iWeek = 99 Then arrWeeks = _ WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sheets(arrSheets(0)).Range("B2: _ BA2"))) 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 For lngRow = 20 To .Cells(Rows.Count, 1).End(xlUp).Row Step 17 arrTmp = Split(.Cells(lngRow, 1), ">") arrItems(1) = myWeek arrItems(2) = arrTmp(0) If UBound(arrTmp) > 0 Then arrItems(3) = arrTmp(1) End If arrItems(4) = .Cells(lngRow, 1) For i = 5 To 20 arrItems(i) = .Cells(lngRow + i - 4, lngC) Next oDaten(.Cells(lngRow, 1).Value & "_" & myWeek) = arrItems Next End If End With Next Next myWeek If oDaten.Count > 0 Then Application.ScreenUpdating = False With Sheets("TotalsRaw") .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(oDaten.Count, 20) = _ WorksheetFunction.Transpose(WorksheetFunction.Transpose(oDaten.items)) End With End If End Sub

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Datenimport

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread