AW: .MergeArea.ClearContents
14.10.2010 09:29:42
Rüdiger
Hallo Franz,
klappt, nur ich benötige die Daten aus den fett und kursiv gemachten Zellen!
Nicht die Zahlen aus i!
'Werte aus Tabelle 1 per Formel einlesen und Werte in Datenarray übernehmen
With .Range("b42")
.Formula = "='" & sTabelle & "'!au" & CStr(i) 'Platz
arrDaten(i, 1) = .Text
End With
With .Range("b44")
.Formula = "='" & sTabelle & "'!ad4" 'Was + WK
arrDaten(i, 2) = .Text
End With
With .Range("b46")
.Formula = "='" & sTabelle & "'!aw" & CStr(i) 'Name
arrDaten(i, 3) = .Text
End With
Hier nochmals das ganze Macro!
'Deklaration Datenarray zum Merken der während des Druckens eingelesenen Daten
Public arrDaten() As String
Sub Urkunde()
Dim MyBox, wksUrkunde As Worksheet, wksTab1 As Worksheet, sTabelle As String
Dim i As Long, j As Long
MyBox = MsgBox("Sind Urkunden im Drucker eingelegt?", vbYesNo)
If MyBox = vbYes Then
'Variablen für die Tabellenblätter in der Prozedur setzen
Set wksUrkunde = Worksheets("Urkunde")
sTabelle = "Tabelle 1" 'Name der Tabelle mit den Daten
Set wksTab1 = Worksheets(sTabelle)
'Dein Code
'Urkunde öffnen
With wksUrkunde
.Activate
.Unprotect
'Datenarray für spätere Auswertung dimensionieren
ReDim arrDaten(11 To 13, 1 To 3)
For i = 11 To 13 Step 1
'Werte aus Tabelle 1 per Formel einlesen und Werte in Datenarray übernehmen
With .Range("b42")
.Formula = "='" & sTabelle & "'!au" & CStr(i) 'Platz
arrDaten(i, 1) = .Text
End With
With .Range("b44")
.Formula = "='" & sTabelle & "'!ad4" 'Was + WK
arrDaten(i, 2) = .Text
End With
With .Range("b46")
.Formula = "='" & sTabelle & "'!aw" & CStr(i) 'Name
arrDaten(i, 3) = .Text
End With
'Druckroutine
Stop
'ActiveWindow.SelectedSheets.PrintOut copies:=1
'Löschroutine
.Range("b42").MergeArea.ClearContents
.Range("b44").MergeArea.ClearContents
.Range("b46").MergeArea.ClearContents
Next i
.Protect 'Urkundenblatt wieder schützen
End With
'Arbeitsblatt öffnen
wksTab1.Activate
Else
MsgBox "Abbruch"
End If
End Sub
'Beispiel für Auswertung der beim Drucken gemerkten Daten
Sub PlazierungsListe()
Dim sMsgText As String, iIndex As Long
On Error GoTo Fehler
sMsgText = "Plazierungen" & vbLf
For iIndex = LBound(arrDaten) To UBound(arrDaten)
sMsgText = sMsgText & vbLf & arrDaten(iIndex, 1) & " " & arrDaten(iIndex, 2) _
& " " & arrDaten(iIndex, 3)
Next
MsgBox sMsgText, vbInformation + vbOKOnly, "Test Datenanzeige"
'Daten-Array löschen
Erase arrDaten
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 9 'Datenarray ist leer
MsgBox "Es wurden noch keine Urkunden gedruckt!", _
vbInformation + vbOKOnly, "Plazierungsliste"
Case Else
MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Gruß Rüdiger