AW: du hast es nicht verstanden
14.12.2010 15:29:25
Maris
Hallo Rudi,
leider ist das nicht so einfach da ich die Daten mit folgendem Code bereits aus einer anderem Tabellenblatt exportiere.
Ein Möglichkeit wäre den Export auch direkt in die Übersichtsmappe. Aber dazu müßte mir jemand beim Code helfen...
Anebi die Beispielmappe (Code zum exportieren der Rohdaten in Kategorie Auto und Motorrad liegt in Modul 1 und unten angefügt)
https://www.herber.de/bbs/user/72683.xls
Sub Aufruf()
On Error GoTo Fehler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Call DatenHolen(Sheets("Rohdaten_Kategorien"), 6)
Call DatenHolen(Sheets("Rohdaten_Produkte"), 6, 7, 2)
Fehler:
Call Aktivieren
If Err 0 Then MsgBox Err.Description, , "Fehler-Nr.: " & Err.Number
End Sub
Sub Aktivieren()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub DatenHolen(shQ As Worksheet, intSpalten As Integer, Optional intZVersatz As Integer, _
Optional intSVersatz As Integer)
Dim shZ As Worksheet
Dim rngZelle As Range, rngFinden As Range
Dim lngS As Long, lngZ As Long
Dim intKW As Integer, intKWSpalte As Integer
intKW = Val(shQ.Range("C3"))
If intKW 53 Then MsgBox "KW """ & intKW & """ existiert nicht.": Exit Sub
Set shZ = Sheets("Rohdaten_Produkte")
For Each rngZelle In shQ.Range(shQ.Cells(5, 1), shQ.Cells(Rows.Count, 1).End(xlUp))
If rngZelle "" Then
If shZ.Name rngZelle Then
If Not SheetExist(rngZelle.Text) Then
rngZelle.Interior.ColorIndex = 3
Application.Goto rngZelle
If MsgBox("Blatt """ & rngZelle & """ existiert nicht!", vbOKCancel, " _
Fehler") = vbCancel Then
Call Aktivieren
End
End If
Else
Set shZ = Sheets(rngZelle.Text)
Set rngFinden = shZ.Rows(2).Find(intKW, , xlValues, xlWhole)
If rngFinden Is Nothing Then MsgBox "KW """ & intKW & """ existiert in """ & _
shZ.Name & """ nicht.": Exit Sub
intKWSpalte = rngFinden.Column
End If
End If
Set rngFinden = shZ.Columns(1).Find(rngZelle.Offset(0, 1), , xlValues, xlWhole)
If rngFinden Is Nothing Then
rngZelle.Offset(0, 1).Interior.ColorIndex = 3
Application.Goto rngZelle.Offset(0, 1)
If MsgBox("Eintrag """ & rngZelle.Offset(0, 1) & """ existiert nicht!", _
vbOKCancel, "Fehler") = vbCancel Then
Call Aktivieren
End
End If
Else
rngFinden.Offset(1 + intZVersatz, intKWSpalte - 1).Resize(intSpalten, 1) = _
WorksheetFunction.Transpose(rngZelle.Offset(0, 2 + intSVersatz).Resize(1, intSpalten))
End If
End If
Next
End Sub
Public Function SheetExist(strName As String) As Boolean
On Error Resume Next
SheetExist = Not Sheets(strName) Is Nothing
End Function