Excel Makro "Denkfehler"

Question

Hallo zusammen,

ich hab folgenden code:

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

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

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

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

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

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

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

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

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

Sheets("X").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 8) = Sheets("Y").Range("F12").Value

Sheets("Y").Range("A12:J12").Copy
Sheets("A").Select
Range("A65536").End(xlUp).Select
Cells(ActiveCell.Row + 1, ActiveCell.Column - 0).PasteSpecial
Application.CutCopyMode = False
Sheets("Y").Select

Sheets("Y").Range("H12:J12").Copy
Sheets("A").Select
Range("A65536").End(xlUp).Select
Cells(ActiveCell.Row - 1, ActiveCell.Column + 7).PasteSpecial
Application.CutCopyMode = False
Sheets("Y").Select

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

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

End If
End With
End Sub

Cells(ActiveCell.Row + 0, ActiveCell.Column + 8) = Sheets("Y").Range("F12").Value



normal sagt das fett gedruckte in dem Code aus der soll die zeile F12 aus Tabelle Y in die gesuchte Zeile einfügen oder? Oder wo ist mein Denkfehler?

Answer 1

Hi Johnny,

diese Codezeile sagt aus, dass der Wert aus Tabelle Y Zelle F12 in die Zelle + 8 Spalten von der aktiven Zelle nach rechts aber nicht in eine Zeile übernommen wird.

Bis später,
Karin

Answer 2

Hallo Karin,

ja dann lag ich doch nicht so falsch. Ich möchte ja das er die Zelle F12 in die andere Tabelle in der gesuchten zeile in eine bestimmte zelle rein kopiert/ersetzt. Wenn ich das Makro ausführe geschieht das jedenfalls nicht warum auch immer ich kann es nicht ganz nachvollziehen. In einem anderen Makro klappts wunderbar :(

Sonst niemand eine Idee warum es nicht klappt?

Answer 3

Hi Johnny,

versuche es mal mit diesem Code (ungetestet):

Option Explicit

Sub Swap()
Dim c As Range, firstAddress As String
Dim strSuch As String, rngBer As Range
Set rngBer = Sheets("X").Range("A3:A" & Sheets("X").Range("A6999").End(xlUp).Row)
Application.ScreenUpdating = False
With rngBer
If Sheets("Y").Range("A12") <> "" Then
Set c = .Find(strSuch, LookIn:=xlValues)
If c Is Nothing Then
MsgBox "Drucker nicht vorhanden"
Exit Sub
Else
firstAddress = c.Address
Do

c.Copy
Sheets("Historie").Range("A1").End(xlDown).Offset(1, 0).PasteSpecial

c.Offset(0, 1).Copy
Sheets("A").Range("A1").End(xlDown).Offset(0, 1).PasteSpecial

c.Offset(0, 4).Copy
Sheets("A").Range("A1").End(xlDown).Offset(0, 2).PasteSpecial

c.Offset(0, 5).Copy
Sheets("A").Range("A1").End(xlDown).Offset(0, 3).PasteSpecial

c.Offset(0, 6).Copy
Sheets("A").Range("A1").End(xlDown).Offset(0, 4).PasteSpecial

c.Offset(0, 7).Copy
Sheets("A").Range("A1").End(xlDown).Offset(0, 5).PasteSpecial

c.Offset(0, 9).Copy
Sheets("A").Range("A1").End(xlDown).Offset(0, 6).PasteSpecial

c.Offset(0, 8) = Sheets("Y").Range("F12").Value

Sheets("Y").Range("A12:J12").Copy
Sheets("A").Cells(Sheets("A").Range("A65536").End(xlUp) + 1, 1).PasteSpecial

Sheets("Y").Range("H12:J12").Copy
Sheets("A").Cells(Sheets("A").Range("A65536").End(xlUp) - 1, 8).PasteSpecial
Application.CutCopyMode = False
Set c = .FindNext(strSuch)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End If
End With
End Sub

Bis später,
Karin

Answer 4

Hallo Karin,

ich habe mal deinen Code getestet aber irgendwie passiert da nix :(

Ich habe einen ähnlichen Code wie ich gepostet habe der total gut funktioniert ... nur werden bei dem Code 3 sachen kopiert und nicht wie bei dem nur eins.... ich poste dir den mal:

Option Explicit
Sub Umzug()
Application.ScreenUpdating = False
Sheets("IST Januar 2009").Select
Dim c, firstAddress
Dim strSuch As String, rngBer As Range
Set rngBer = Range("A3:A" & Range("A7").End(xlUp).Row)
With rngBer
strSuch = Sheets("Makros").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("IST Januar 2009").Select
ActiveCell.Copy
Sheets("Druckerhistorie").Select
Range("A1").End(xlDown).Offset(1, 0).PasteSpecial

Sheets("IST Januar 2009").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1).Copy
Sheets("Druckerhistorie").Select
Range("A1").End(xlDown).Offset(0, 1).PasteSpecial

Sheets("IST Januar 2009").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 4).Copy
Sheets("Druckerhistorie").Select
Range("A1").End(xlDown).Offset(0, 2).PasteSpecial

Sheets("IST Januar 2009").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 4).Copy
Sheets("Druckerhistorie").Select
Range("A1").End(xlDown).Offset(0, 2).PasteSpecial

Sheets("IST Januar 2009").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 5).Copy
Sheets("Druckerhistorie").Select
Range("A1").End(xlDown).Offset(0, 3).PasteSpecial

Sheets("IST Januar 2009").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 6).Copy
Sheets("Druckerhistorie").Select
Range("A1").End(xlDown).Offset(0, 4).PasteSpecial

Sheets("IST Januar 2009").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 7).Copy
Sheets("Druckerhistorie").Select
Range("A1").End(xlDown).Offset(0, 5).PasteSpecial

Sheets("IST Januar 2009").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 9).Copy
Sheets("Druckerhistorie").Select
Range("A1").End(xlDown).Offset(0, 6).PasteSpecial

Sheets("IST Januar 2009").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = Sheets("Makros").Range("B5").Value
Cells(ActiveCell.Row + 0, ActiveCell.Column + 6) = Sheets("Makros").Range("E5").Value
Cells(ActiveCell.Row + 0, ActiveCell.Column + 9) = Sheets("Makros").Range("G5").Value

Sheets("Makros").Range("A5:J5").Copy
Sheets("Druckerhistorie").Select
Range("A65536").End(xlUp).Select
Cells(ActiveCell.Row + 1, ActiveCell.Column - 0).PasteSpecial
Application.CutCopyMode = False
Sheets("Makros").Select

Sheets("Makros").Range("H5:J5").Copy
Sheets("Druckerhistorie").Select
Range("A65536").End(xlUp).Select
Cells(ActiveCell.Row - 1, ActiveCell.Column + 7).PasteSpecial
Application.CutCopyMode = False
Sheets("Makros").Select

Sheets("IST Januar 2009").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 5).Copy
Sheets("Druckerhistorie").Select
Range("A1").End(xlDown).Offset(0, 3).PasteSpecial

Sheets("IST Januar 2009").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 7).Copy
Sheets("Druckerhistorie").Select
Range("A1").End(xlDown).Offset(0, 5).PasteSpecial

End If
End With
End Sub

was ich gerne hätte :

Das Makro soll nur die Zelle F13 aus der Tabelle Makros kopieren und in der gesuchten Zeile in der Tabelle "IST Januar 2009" einfügen (Spalte H)

Gut die Zahlen oben im code stimmen nicht 100% überein weil das ja für ein anderes makro ist das hab ich mal 1 zu 1 übernommen ;)

Liebe Grüsse

Johnny

Answer 5

Hi Johnny,

sorry, da stand als Suchbegriff noch dein Variablenname drin, der ja nun leer ist. Änder diese Zeile:

Set c = .Find(Sheets("Y").Range("A12"), LookIn:=xlValues)

Den Code-Teil Dim strSuch As String kannst du weglassen, da der Suchbegriff aus der Zelle direkt ausgelesen wird.

Bis später,
Karin