Excel Makro

Question

Hallo,

kennt jemand ein Makro mit dem ich in Excel folgendes machen kann:

Ich habe eine Excel Datei mit 3 Arbeitsblättern.

Nun was ich gerne machen würde:

Ich möchte in Tabelle3 einen wert eintragen(zb irgendein name) und das Makro soll mir das in Tabelle1 raussuchen. Anschliessend nach Tabelle 2 kopieren und das ganz am ende. Was mich aber stuzig macht ob das überhaupt geht :
Das Makro soll nicht nur das Suchkriterium kopieren sondern auch noch 7 Spalten in der Zeile von Tabelle1. Ist das überhaupt per Makro möglich sowas?

Answer 1

Hallo fedjo ,

also das mit der Suche und kopieren klappt schon mal wunderbar hätte nicht gedacht das es überhaupt geht *beide daumen hoch*

Ein hoffentlich für dich kleines anliegen habe ich noch.... ;)

Wäre es evt möglich nachdem die Zeile in Tabelle 2 kopiert wurde, die gesuchte Zeile in Tabelle1 mit der aus Tabelle3 zu ersetzen bzw 3 spalten in diesem fall Spalte B, G und J?
Und zu guter letzt noch die Zeile aus Tabelle3 in die letzte Zeile in Tabelle2 kopieren ;)

Vielen lieben dank schon mal für deine tolle mühe.

Gruss
Johnny

Answer 2

Hallo Johnny,
wenn ich das alles richtig verstanden habe dann so:

Option Explicit
Sub Suchen()
Application.ScreenUpdating = False
Sheets("Tabelle1").Select
Dim c, firstAddress
Dim strSuch As String, rngBer As Range
Set rngBer = Range("A3:A" & Range("A65536").End(xlUp).Row)
With rngBer
strSuch = Sheets("Tabelle3").Range("A5").Value
If strSuch = "" Then
Exit Sub
End If
Set c = .Find(strSuch, LookIn:=xlValues)
If c Is Nothing Then
MsgBox "Eintrag nicht vorhanden"
Else
firstAddress = c.Address
Do
c.Activate
Loop While Not c Is Nothing And c.Address <> firstAddress
Sheets("Tabelle1").Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 9)).Copy
Sheets("Tabelle2").Select
Range("A65536").End(xlUp).Select
Cells(ActiveCell.Row + 1, ActiveCell.Column).PasteSpecial
Range("A65536").End(xlUp).Select
Application.CutCopyMode = False
Sheets("Tabelle1").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = Sheets("Tabelle3").Range("B5").Value
Cells(ActiveCell.Row + 0, ActiveCell.Column + 6) = Sheets("Tabelle3").Range("G5").Value
Cells(ActiveCell.Row + 0, ActiveCell.Column + 9) = Sheets("Tabelle3").Range("J5").Value
Sheets("Tabelle3").Range("A5:J5").Copy
Sheets("Tabelle2").Select
Range("A65536").End(xlUp).Select
Cells(ActiveCell.Row + 2, ActiveCell.Column - 0).PasteSpecial
Application.CutCopyMode = False
Sheets("Tabelle3").Select
End If
End With
End Sub

Gruß
fedjo

Answer 3

Hallo fedjo,

ich bin einfach sprachlos das sowas doch geht :-)

Es ist schon fast perfekt....

statt die ganze Zeile von Tabelle1 sollen doch nur paar Spalten in Tabelle2 kopiert werden. Wo kann ich das in dem Makro genau ändern? Die Spalten sind A, B, E, F, G,H und J.

Keine ahnung wie ich dir fedjo dafür schon mal DANKEN kann :)
Echt sau starke leistung ;-)

Grüsse

Johnny

Answer 4

Dazu ergänzen sollte ich noch das die Kopierten Spalten von Tabelle1 in die Tabelle2 fortlaufend kopiert werden sollen.

SpalteA nach A
SpalteB nach B
SpalteE nach C
SpalteF nach D
SpalteG nach E
SpalteH nach F
SpalteJ nach G

Lg

Johnny

Answer 5

Hallo Johnny,
ich habe den Code noch mal nach deinen Angaben angepasst.
http://www.file-upload.net/download-1485955/Versuch1.xls.html
Gruß
fedjo

Answer 6

Hallo,

Irgendwas haut bei:

Option Explicit
Sub Suchen()
Application.ScreenUpdating = False
Sheets("Tabelle1").Select
Dim c, firstAddress
Dim strSuch As String, rngBer As Range
Set rngBer = Range("A3:A" & Range("A65536").End(xlUp).Row)
With rngBer
strSuch = Sheets("Tabelle3").Range("A5").Value
If strSuch = "" Then
Exit Sub
End If
Set c = .Find(strSuch, LookIn:=xlValues)
If c Is Nothing Then
MsgBox "Eintrag nicht vorhanden"
Exit Sub
Else
firstAddress = c.Address
Do
c.Activate
Loop While Not c Is Nothing And c.Address <> firstAddress

Sheets("Tabelle1").Select
ActiveCell.Copy
Sheets("Tabelle2").Select
Range("A1").End(xlDown).Offset(1, 0).PasteSpecial

Sheets("Tabelle1").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1).Copy
Sheets("Tabelle2").Select
Range("A1").End(xlDown).Offset(0, 1).PasteSpecial

Sheets("Tabelle1").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 4).Copy
Sheets("Tabelle2").Select
Range("A1").End(xlDown).Offset(0, 2).PasteSpecial

Sheets("Tabelle1").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 5).Copy
Sheets("Tabelle2").Select
Range("A1").End(xlDown).Offset(0, 3).PasteSpecial

Sheets("Tabelle1").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 6).Copy
Sheets("Tabelle2").Select
Range("A1").End(xlDown).Offset(0, 4).PasteSpecial


Sheets("Tabelle1").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 7).Copy
Sheets("Tabelle2").Select
Range("A1").End(xlDown).Offset(0, 5).PasteSpecial

Sheets("Tabelle1").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 9).Copy
Sheets("Tabelle2").Select
Range("A1").End(xlDown).Offset(0, 6).PasteSpecial

Sheets("Tabelle1").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = Sheets("Tabelle3").Range("B5").Value
Cells(ActiveCell.Row + 0, ActiveCell.Column + 6) = Sheets("Tabelle3").Range("G5").Value
Cells(ActiveCell.Row + 0, ActiveCell.Column + 9) = Sheets("Tabelle3").Range("J5").Value

Sheets("Tabelle3").Range("A5:J5").Copy
Sheets("Tabelle2").Select
Range("A65536").End(xlUp).Select
Cells(ActiveCell.Row + 2, ActiveCell.Column - 0).PasteSpecial
Application.CutCopyMode = False
Sheets("Tabelle3").Select
End If
End With
End Sub

nicht so ganz hin.
Es wird aus irgendwelchen gründen auch immer die zeile aus Tabelle1 in die Tabelle2 kopiert. Auch in deiner versuchs datei kommt immer nur die zeile aus Tabelle3 in die Tabelle2.

Jemand ne Idee woran das liegt?

Lg

Johnny

Answer 7

Es wird aus irgendwelchen gründen auch immer die zeile aus Tabelle1 in die Tabelle2 kopiert.

Das sollte heissen das die NICHT kopiert wird :/

Answer 8

3fach post :-( *geb mir die EDIT funktion* ^^

ok in deiner Versuchsdatei gehts .... aber in meiner gehts irgendwie nicht. Von Tab3 wird in Tab2 kopiert aber leider nicht von Tab1 in Tab 2...

Answer 9

hm okay mein letzter post ^^

Es KLAPPT in meiner 2ten Tabelle waren noch paar freie Zeilen dann kann es natürlich nicht klappen.

@fedjo VIELEN DANK *daumen hoch*