AW: Werte mit VBA kopieren
14.02.2008 19:13:45
fcs
Hallo markus,
das erfordert dann im Makro etwas mehr "Vorarbeit". Es gibt dann allerdings ein Problem, wenn bei einem Kopiervorgang die gleiche Kombination von "Gruppe" und "Nummer" in mehren Zeilen vorkommt. Es ist dann immer nur der letzte Summenwert in den Blättern vorhanden.
Gruß
Franz
Public Sub Kopierenorg()
Dim WkSh_Q As Worksheet ' das Quell-Tabellenblatt - Statistik
Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - wird dynamisch festgelegt
Dim lZeile_Q As Long ' For/Next Schleifen-Index der Zeile im Quell-Blatt
Dim iSpalte As Integer ' For/Next Schleifen-Index der Spalten
Dim sSuchbegr As String ' der Suchbegriff - hier die Gruppe
Dim rZelle As Range ' die Zelle in der die Gruppe gefunden wurde / oder nicht
Dim arrBlattNr, iI As Integer
Dim arrSpalte() As Integer 'Feld für auszufüllende Spalte im Blatt
Application.ScreenUpdating = False ' kein Bildschirm-Update während des Makro-Laufs
arrBlattNr = Array(810, 815, 820)
ReDim arrSpalte(LBound(arrBlattNr) To UBound(arrBlattNr))
For iI = LBound(arrBlattNr) To UBound(arrBlattNr)
Select Case arrBlattNr(iI) ' die Nummer als Case auswerten
Case 810 ' ist es die Nummer für Tabellenblatt 810 ?
Set WkSh_Z = Worksheets("810")
Case 815 ' ist es die Nummer für Tabellenblatt 815 ?
Set WkSh_Z = Worksheets("815")
Case 820 ' ist es die Nummer für Tabellenblatt 820 ?
Set WkSh_Z = Worksheets("820")
End Select
For iSpalte = 3 To 8 ' die erste freie Spalte in Zeile im Blatt finden
If iSpalte = 8 Then
MsgBox "Es sind schon alle Spalten im Blatt " & WkSh_Z.Name _
& " ausgefüllt! Tabelle und Makro anpassen!"
Exit Sub
Else
If WkSh_Z.Cells(5, iSpalte) = "" Then ' ist die Zelle der ersten Gruppe leer ?
arrSpalte(iI) = iSpalte
With WkSh_Z
.Range(.Cells(5, iSpalte), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, _
iSpalte)).Value = 0
End With
Exit For ' und die For/Next Schleife verlassen
End If
End If
Next iSpalte ' die nächste Spalte heranziehen
Next iI
Set WkSh_Q = Worksheets("Statistik") ' das Quell-Tabellenblatt festlegen
For lZeile_Q = 2 To WkSh_Q.Cells(Rows.Count, 2).End(xlUp).Row
Set WkSh_Z = Nothing
sSuchbegr = WkSh_Q.Cells(lZeile_Q, 2).Value ' die Gruppe als Suchbegriff speichern
'Zieltabelle gemäß Nummer setzen
Select Case WkSh_Q.Cells(lZeile_Q, 5).Value ' die Nummer als Case auswerten
Case 810 ' ist es die Nummer für Tabellenblatt 810 ?
Set WkSh_Z = Worksheets("810")
iSpalte = arrSpalte(LBound(arrSpalte))
Case 815 ' ist es die Nummer für Tabellenblatt 815 ?
Set WkSh_Z = Worksheets("815")
iSpalte = arrSpalte(LBound(arrSpalte) + 1)
Case 820 ' ist es die Nummer für Tabellenblatt 820 ?
Set WkSh_Z = Worksheets("820")
iSpalte = arrSpalte(LBound(arrSpalte) + 2)
End Select
If Not WkSh_Z Is Nothing Then
With WkSh_Z.Columns(2) ' im Blatt die Spalte 2 = B festlegen
' in der Spalte 2 = B nach der Gruppe suchen
Set rZelle = .Find(sSuchbegr, LookAt:=xlWhole, LookIn:=xlValues)
If Not rZelle Is Nothing Then ' wurde die Gruppe gefunden ?
' die Summe übertragen
If IsEmpty(WkSh_Q.Cells(lZeile_Q, 6)) Then
WkSh_Z.Cells(rZelle.Row, iSpalte).Value = 0
Else
WkSh_Z.Cells(rZelle.Row, iSpalte).Value = WkSh_Q.Cells(lZeile_Q, 6).Value
End If
End If
End With
End If
Next lZeile_Q
Application.ScreenUpdating = True ' den Bildschirm-Update wieder zulassen
End Sub