Zellinhalte in anderes Sheet übertragen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Private Sub Worksheet_Change(ByVal Target As Range) Dim WkSh_Q As Worksheet Dim WkSh_Z As Worksheet Dim lZeile As Long If Target.Count > 1 Then Exit Sub If Target.Address = "$K$5" Then If Target.Value > 0 Then Application.ScreenUpdating = False Set WkSh_Q = ThisWorkbook.Worksheets("Tabelle5") Set WkSh_Z = ThisWorkbook.Worksheets("Tabelle1") lZeile = WkSh_Z.Cells(Rows.Count, 1).End(xlUp).Row + 1 WkSh_Z.Range("A" & lZeile).Value = WkSh_Q.Range("B1").Value WkSh_Z.Range("B" & lZeile).Value = WkSh_Q.Range("F7").Value WkSh_Z.Range("C" & lZeile).Value = WkSh_Q.Range("E2").Value WkSh_Z.Range("D" & lZeile).Value = WkSh_Q.Range("F2").Value WkSh_Z.Range("E" & lZeile).Value = WkSh_Q.Range("G2").Value WkSh_Z.Range("F" & lZeile).Value = WkSh_Q.Range("K2").Value End If Application.ScreenUpdating = True End If End Sub

Hallo Marco,
probier mal die beiden Varianten im Modul "DieseArbeitsmappe"

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Zei As Long
If Target.Count > 1 Then Exit Sub
If Target.Address = "$K$5" Then
Application.ScreenUpdating = False
If Target.Value > 0 Then
With Worksheets("Tabelle1")
Zei = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & Zei).Value = Sh.Range("B1").Value
.Range("B" & Zei).Value = Sh.Range("F7").Value
.Range("C" & Zei).Value = Sh.Range("E2").Value
.Range("D" & Zei).Value = Sh.Range("F2").Value
.Range("E" & Zei).Value = Sh.Range("G2").Value
.Range("F" & Zei).Value = Sh.Range("K2").Value
End With
End If
Application.ScreenUpdating = True
End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Zei As Long
If Target.Count > 1 Then Exit Sub
If Target.Address = "$K$5" Then
Application.ScreenUpdating = False
If Target.Value > 0 Then
With Worksheets("Tabelle1")
Zei = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & Zei & ":F" & Zei).Value = Sh.Range("B1,F7,E2,F2,G2,K2").Value
End With
End If
Application.ScreenUpdating = True
End If
End Sub

Gruß
Reinhard

Sub uebertrag() Dim i As Long Dim a As Long For i = ThisWorkbook.Sheets.Count To 2 Step -1 With ThisWorkbook.Sheets(i) If IsNumeric(.Cells(5, 11)) And .Cells(5, 11).Value > 0 Then a = ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 Sheets(1).Cells(a, 1) = .Cells(1, 2) Sheets(1).Cells(a, 2) = .Cells(7, 6) Sheets(1).Cells(a, 3) = .Cells(2, 5) Sheets(1).Cells(a, 4) = .Cells(2, 6) Sheets(1).Cells(a, 5) = .Cells(2, 7) Sheets(1).Cells(a, 6) = .Cells(2, 11) End If End With Next i End Sub

Beliebteste Forumthreads (12 Monate)

Zellinhalte in anderes Sheet übertragen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread