Sub kopieren3()
Dim strSuch, ii As Integer, rngF As Range, lngZ As Long, lngF As Long
Dim rngSuch(1) As Range, jj As Integer, lngSpV(1), lngSpB(1)
Dim lngZiel As Long, lngZneu As Long
strSuch = Split("Öl Schwefel Eisen Kupfer") ' Suchbegriffe
Set rngSuch(0) = Range(Cells(8, 2), Cells(507, 2)) _
' Suchbereich 1
Set rngSuch(1) = Range(Cells(8, 7), Cells(507, 7)) _
' Suchbereich 2
lngSpV(0) = 1: lngSpB(0) = 4 _
' Copy Spalten 1
lngSpV(1) = 6: lngSpB(1) = 9 _
' Copy Spalten 2
lngZiel = 517 _
' Zielzeile ab
For jj = 0 To 1
lngZneu = lngZiel
For ii = 0 To UBound(strSuch)
With rngSuch(jj)
Set rngF = .Find(What:=strSuch(ii), after:=rngSuch(jj)(1, 1), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
If Not rngF Is Nothing Then
lngZ = rngF.Row
lngF = lngZ
Do
Range(Cells(lngZneu, lngSpV(jj)), Cells(lngZneu, lngSpB(jj))) = _
Range(Cells(lngZ, lngSpV(jj)), Cells(lngZ, lngSpB(jj))).Value
Range(Cells(lngZ, lngSpV(jj)), Cells(lngZ, lngSpB(jj))).ClearContents
lngZneu = lngZneu + 1
Set rngF = .FindNext(rngF)
If rngF Is Nothing Then
lngZ = lngF
Else
lngZ = rngF.Row
End If
Loop While lngZ
Sub Makro4()
' Makro4 Makro
' Makro am 18.04.2008 von maxi aufgezeichnet
' Tastenkombination: Strg+n
Range("A6:D6").Select
Range("D6").Activate
Selection.Copy
Application.Run "'Mappe1'!kopieren3"
ActiveWindow.SmallScroll Down:=15
Range("A516:D516").Select
ActiveSheet.Paste
Range("F516:I516").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=9
Range("I525").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=SUM(R[-8]C:R[-1]C)"
Range("F525:I525").Select
Range("I525").Activate
Selection.NumberFormat = "General"
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Range("I517:I525").Select
Range("I525").Activate
Selection.NumberFormat = "#,##0.00"
Range("D517:D525").Select
Range("D525").Activate
Selection.NumberFormat = "#,##0.00"
Range("G525").Select
ActiveCell.FormulaR1C1 = "Summe"
With ActiveCell.Characters(Start:=1, Length:=5).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("G525").Select
Selection.Copy
Range("B525").Select
ActiveSheet.Paste
Range("D517:D525").Select
Range("D525").Activate
Application.CutCopyMode = False
Range("D525").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-8]C:R[-1]C)"
Range("A525:D525").Select
Range("D525").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Range("E526").Select
ActiveWindow.SmallScroll ToRight:=1
End Sub
Viele Grüße
maxi
Application.Run "'Mappe1'!kopieren3"
Jetzt ist mir nicht klar, was du machen willst. Soll das Makro kopieren3 jetzt in die Mappe mit dem Makro4 integriert werden? Das Übersichtlichste ist, du lässt beide Codes getrennt und rufst das Makro in der selben Zeile auf, nur anstelle des bisherigen schreibst du einfach kopieren3. Deine Codezeilen sollten dann so aussehen
Range("A6:D6").Select
Range("D6").Activate
Selection.Copy
kopieren3
Ich habe mich jetzt aber nicht um den restlichen Code gekümmert. Nur als Hinweis - in VBA kann zu 99% auf Select und Activate verzichtet werden. Das macht den Code wesentlich schneller.