For Schleifen

Sub ZeichenKopieren() Dim Spalte1 As Integer Dim Spalte2 As Integer For Spalte1 = 1 To 2 Worksheets("Tabelle1").Cells(8, Spalte1).Value = Worksheets("Tabelle1").Cells(1, Spalte1) Next Spalte1 For Spalte2 = 3 To 6 Worksheets("Tabelle1").Cells(8, Spalte2).Value = Worksheets("Tabelle1").Cells(1, Spalte2) Next Spalte2 End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: For Schleifen

09.02.2021 19:48:02

Werner

AW: For Schleifen

09.02.2021 20:01:29

Piet

AW: For Schleifen

09.02.2021 23:19:04

Thomas

AW: For Schleifen

10.02.2021 11:46:07

Piet

Sub ZeichenKopieren() Dim Spalte1 As Integer Dim Spalte2 As Integer Dim k As Integer 'oder wdh For k = 1 To 6 With Worksheets("Tabelle1") z=z+1: 'falls du 6mal eine Zeile tiefer gehen willst! For Spalte1 = 1 To 2 .Cells(8 + z, Spalte1 + 17).Value = .Cells(1, Spalte1) 'ab Spalte 20! Next Spalte1 For Spalte2 = 3 To 6 .Cells(8 + z, Spalte2 + 17).Value = .Cells(1, Spalte2) 'Ab Spalte 20! Next Spalte2 End With Next k End Sub

Sub ZeichenKopieren() Dim Spalte1 As Integer Dim Spalte2 As Integer Dim k As Integer 'oder wdh Dim Z As Integer For k = 1 To 6 With Worksheets("Tabelle1") Z = Z + 1 'falls du 6mal eine Zeile tiefer gehen willst! For Spalte1 = 1 To 2 .Cells(8 + Z, Spalte1 + 17).Value = .Cells(0 + Z, Spalte1) 'ab Spalte 20! Next Spalte1 For Spalte2 = 4 To 6 .Cells(8 + Z, Spalte2 + 17).Value = .Cells(0 + Z, Spalte2) 'Ab Spalte 20! Next Spalte2 End With Next k End Sub

Hallo Thomas
bei kleinen Datenmengen macht sich der Unterschied kaum bemerkbar. Die modernen PC arbeiten im milli Sekunden Bereich. Interessant wird es ab 1000 Daten aufwaerts, dann merkt man den Zeitunterschied. Um VBA zu üben habe ich mir angewöhnt nur aus Interesse auch mal mehrere Lösungen zu schreiben und auszuprobieren. Man lernt dadurch immer klüger zu programmieren.
Hier mal ein Beispiel für dich.Diesen Code habe ich heute geschrieben, für ein anderes Forum. Mit einer Beispieldatei wo man sehen konnte was er wirklich will! - Die 1. Anfrage dazu war aber hier im Herber Forum! Thread - Excel Makrorecorder - Georg De Min 08.02.2021 18:21:43
Vergleich bitte mal die Codes. Die Antwort in Herber zeigte Möglichkeiten wie man es machen kann. Der neue Code berücksichtigt die Tabelle mit 11,9 und 8 Spalten und zwei unbekannte Spalten die ausgewertet werden mussten. Da kam selbst ich ins überlegen, bis mir die Offset Version einfiel.
mfg Piet

Option Explicit
Sub Tabelle1_CoronaInfo_ausfüllen()
Dim lz1 As Long, z As Long, i As Long
Dim sp As Integer, csp As Integer
Dim of As Integer, gsp As Integer
Dim Tb1 As Worksheet
Set Tb1 = Worksheets("Tabelle1")
Application.ScreenUpdating = False
On Error GoTo Fehler
With Worksheets("Tabelle2")
'LastZell in Tabelle1 ermitteln
lz1 = Tb1.Range("A7").End(xlDown).Row
'nach Datumin Spalte A suchen
For z = 7 To lz1 + 1
If Tb1.Cells(z, 1) = .[a1] Then Exit For
Next z
If z > lz1 Then MsgBox "Datum nicht gefunden!": Exit Sub
'Schleife zum Daten kopieren
For i = 1 To 7
'sp = Offset zwischen den Datenblöcken
If i = 2 Then sp = 11 Else _
If i = 3 Then sp = 9 Else csp = 8
'csp = Anzahl zu kopierende Spalten
If i = 1 Then csp = 11 Else _
If i = 2 Then csp = 9 Else csp = 8
'gsp = gesamte Spaltenverschiebung!
gsp = gsp + sp  'gsp mit Spalte addieren
If i > 5 Then gsp = gsp - 1  'Korrektur! bei AD,AM
Tb1.Cells(z, 2).Offset(0, gsp).Resize(1, csp).Copy
.Cells(i + 1, 3).PasteSpecial xlPasteValues
Next i
Application.CutCopyMode = False
Range("A1").Select
End With
Exit Sub
Fehler: MsgBox "unerwarteter Fehler beim auflisten"
End Sub

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread