Hallo liebe Wissenden,
sitze hier gerade auf Arbeit über einem "Makro-Problem".
Habe zwar eine Vermutung aber leider nur gefährliches Halbwissen was Makros angeht.
Aus diesem Grund wende ich mich an euch da draußen.
Hier ein Versuch die Aufgabe umfassend zu umschreiben:
In dem aufgeführten Makro soll eine importierte Tabelle nach verschiedenen Kriterien gefiltert werden.
- Also bis jetzt alles ganz harmlos ohne Makroeinsatz.
Das Makro soll nun die Werte (Auftragsnr, Artikelnr, Bezeichnung,...) aus der gefilterten Tabelle einzeln in dafür vorgesehene Formulare (Tabelle1) Kopieren und diese somit selbsständig füllen.
- In der jetzigen Version Kopiert das Makro nur die gefilterten Werte der ersten Spalte, die restlichen "ausgeblendeten" Werte werden mitkopiert.
Genau dort liegt mein Problem.
Der Filter wird nicht beibehalten.
Für eine schnelle und praktikable Lösung bin ich immer zu Begeistern ;-).
Hier das Makro:
Sub MontageFertigmeldungen()
Application.Dialogs(xlDialogPrinterSetup).Show
'Thömel, 24.8.12:
Dim blatt, filblatt As Worksheet
Dim ktr As Variant
Dim wert As Range
Set blatt = Worksheets("MDA Ad hoc")
Set filblatt = Worksheets("FilterData")
'Thömel, 24.8.12:
'Kopiert die gefilterten Werte in die Tabelle FilterData:
filblatt.Cells.Clear
blatt.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
filblatt.Cells(1, 1)
Sheets("MDA Ad hoc").Select
lReihe = LetzteReihe
For i = 3 To lReihe
'Thömel, 24.8.12:
ktr = blatt.Range("A" & i)
Set wert = filblatt.Range("A1:A1000").Find(ktr)
'Thömel, 24.8.12:
If Not wert Is Nothing Then
Sheets("MDA Ad hoc").Select
Range("A" & i).Select
Selection.Copy
Sheets("Tabelle1").Select
Range("C5:D6").Select
ActiveSheet.Paste
Selection.Font.Size = 13.5
Sheets("MDA Ad hoc").Select
Range("B" & i).Select
Selection.Copy
Sheets("Tabelle1").Select
Range("E8:E9").Select
ActiveSheet.Paste
Selection.Font.Size = 13.5
Sheets("MDA Ad hoc").Select
Range("D" & i).Select
Selection.Copy
Sheets("Tabelle1").Select
Range("G8:G9").Select
ActiveSheet.Paste
Selection.Font.Size = 13.5
Sheets("MDA Ad hoc").Select
Range("C" & i).Select
Selection.Copy
Sheets("Tabelle1").Select
Range("F5:G6").Select
ActiveSheet.Paste
With ActiveCell.Characters(Start:=1, Length:=7).Font
.Name = "MS Sans Serif"
.FontStyle = "Standard"
.Size = 10
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("C5:D6").Select
Selection.Font.Size = 18
Selection.Font.Bold = True
'ActiveWindow.SelectedSheets.PrintPreview
ExecuteExcel4Macro "PRINT(1,,,1,,FALSE,,,,,,2,,,TRUE,,FALSE)"
Range("E8:E9").Select
Selection.ClearContents
Range("F5:G6").Select
Selection.ClearContents
Range("C5:D6").Select
Selection.ClearContents
Range("G8:G9").Select
Selection.ClearContents
End If
'Sheets("MDA Ad hoc").Select
Next i
End Sub
Public Function LetzteReihe()
Dim objWks As Worksheet
Dim nLastRow As Long
Dim strMsg As String
Set objWks = ActiveSheet
With objWks
If Application.WorksheetFunction.CountA(.Cells) > 0 Then
On Error Resume Next
nLastRow = .Cells.Find(What:="*", After:=.Cells(1), _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
On Error GoTo 0
Else
strMsg = "Das Tabellenblatt enthält keine Daten!"
End If
End With
Set objWks = Nothing
LetzteReihe = nLastRow
End Function
Vielen Dank und Grüße,
Kapa
