VBA Zellen mit x kopieren aber nur bestimmte Zellen

Hallo zusammen,
habe folgendes problem, undzwar sieht meine Tabelle so aus
__A____B______C______D_____E_______F_____G____H
1_x___alf___test1_________________1234___a____ist ein Auto
2_y________________Ulf____test2__________b____ist ein Krad
3
4
5
6_y________________Ulf____test6__________c____ist ein Krad
7
8_x__alf____test9_________________1004___d____ist ein LKW
9
Wenn jetzt in "Spalte A" ein "x" steht kopiere aus "Tabelle1" die Zellen "B1" und "C1" und "F1" und G1" und "H1" nach "Tabelle2" aber nach Zellen "G1" "H1" "I1" "J1" "K1".
nächste spalte mit einem "x" gleiche Spalten in "Tabelle2" aber um 1 weiter, also "G2" "H2" "I2" "J2" "K2"...usw.
Das gleiche Prinzip jetzt nun für "y"
...."Tabelle1" Zellen "D2" "E2" "G2" "H2" nach "Tabelle2" aber nach Zellen "N1" "O1" "P1" "Q1".
nächste spalte mit einem "y" gleiche Spalten in "Tabelle2" aber um 1 weiter, also "N2" "O2" "P2" "Q2"...usw.
Weiß jemand wie man das realisieren kann.
gruß
balta

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub CopyXY() Dim zz As Long, rngB As Range, rngN As Range With Sheets("Tabelle1") For zz = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row Select Case .Cells(zz, 1) Case "x" If rngB Is Nothing Then Set rngB = _ Union(.Cells(zz, 2).Resize(, 2), .Cells(zz, 6).Resize(, 3)) Else Set rngB = Union(rngB, _ Union(.Cells(zz, 2).Resize(, 2), .Cells(zz, 6).Resize(, 3))) End If Case "y" If rngN Is Nothing Then Set rngN = _ Union(.Cells(zz, 4).Resize(, 2), .Cells(zz, 7).Resize(, 2)) Else Set rngN = Union(rngN, _ Union(.Cells(zz, 4).Resize(, 2), .Cells(zz, 7).Resize(, 2))) End If End Select Next zz End With With Sheets("Tabelle2") If Not rngB Is Nothing Then rngB.Copy .Cells(1, 7) If Not rngN Is Nothing Then rngN.Copy .Cells(1, 14) End With End Sub

Hi,
inzwischen habe ich es auch gemacht, also schicke es Dir als Nr.2 :-).
Option Explicit
Private Const SOURCE_SHEET_NAME = "Tabelle1"
Private Const TARGET_SHEET_NAME = "Tabelle2"
Private sourceSheet As Worksheet
Private targetSheet As Worksheet
Private criteriaRange As Range
Private criteriaCell As Range


Public Sub BaltaSort()
On Error GoTo BaltaSortError
Set sourceSheet = Worksheets(SOURCE_SHEET_NAME)
Set targetSheet = Worksheets(TARGET_SHEET_NAME)
With sourceSheet
Set criteriaRange = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row, 1).Cells
Dim cellsToCopy As Range
For Each criteriaCell In criteriaRange
If (Strings.StrComp(Strings.Trim(criteriaCell.Text), "x") = 0) Then
Set cellsToCopy = Union(.Range("B" & criteriaCell.Row), _
.Range("C" & criteriaCell.Row), _
.Range("F" & criteriaCell.Row), _
.Range("G" & criteriaCell.Row), _
.Range("H" & criteriaCell.Row))
cellsToCopy.Copy targetSheet.Range("G" & targetSheet.Range("G" & Rows.Count).End(xlUp). _
Row + 1)
ElseIf (Strings.StrComp(Strings.Trim(criteriaCell.Text), "y") = 0) Then
Set cellsToCopy = Union(.Range("D" & criteriaCell.Row), _
.Range("E" & criteriaCell.Row), _
.Range("G" & criteriaCell.Row), _
.Range("H" & criteriaCell.Row))
cellsToCopy.Copy targetSheet.Range("N" & targetSheet.Range("N" & Rows.Count).End(xlUp). _
Row + 1)
End If
Next criteriaCell
End With
Exit Sub
BaltaSortError:
MsgBox "Error [" & Err.Number & "] occured" & vbCrLf & "Description: [" & Err.Description & "] _
", vbCritical, "Error in function 'BaltaSort'"
End Sub

Beliebteste Forumthreads (12 Monate)

VBA Zellen mit x kopieren aber nur bestimmte Zellen

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

358 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Zellen mit x kopieren aber nur bestimmte Zellen

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

358 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread