AW: Mit Checkbox suchen und Datei kopieren
14.01.2019 18:28:55
Piet
Hallo Richard
ich schicke dir mal einen sog. simpel Makro Code der aus dem Herber Forum stammt.
Habe ihn selbst nicht getestet, denke aber das er funktioniert.
Du wirst nicht umhin kommen dch ein wenig mit VBA Grundwissen zu beschaeftigen, denn der Code muss über Offset auf die richtige Zelle mit dem Datei Namen (PDF) angepasst werden! Die 1. MsgBox zeigt dir die Adresse der linken oberen Ecke jeder KontrollBox nach dem Anklicken. Die müssen bei 30 Stück bitte auch genau sauber ausgerichtet sein!
Die 2. MsgBox zeigt dir den Wert über Offset(x,x), d.h., neben unter oder über dieser Zelle. Dafür gibt es ein kleines Demp Programm das dir die Zellverschiebung anzeigt. Für Recht oder unten gelten Plus Zahlen von 0 bis x, für links oder oben gelten -Zahlen!
Erst wnn du herausgefunden hast wie du die PDF Datei aus der richtigen Zelle laedst kannst du die Zahlenwerte ins Kopier Makro an Stelle von "x,y" eingeben, und diesen Befehl im Kopiermakro entfernen. danach sollte das Makro laufen!
Call RichtigeZelle_finden '** zuerst Offset finden!!
Exit Sub - '** diesen Teil erst nach dem Finden von Offset löschen
Den 30 Kontroll Boxen must du allen das gleiche Makro zuweisen, "BeiKlick_PDF_kopieren"
Das Makro startet nur beim Haeckchen für KontrollBox "aktiv" und kopiert diese PDF Datei
mfg Piet
Sub BeiKlick_PDF_kopieren()
Dim sQuelle$, sZiel$, sDatei$
Dim ZellAdr As String
Call RichtigeZelle_finden '** zuerst Offset finden!!
Exit Sub
'** diesen Teil erst nach dem Finden von Offset löschen
'nur bei aktiver CheckBox Makro ausführen
If ActiveSheet.CheckBoxes(Application.Caller).Value = 1 Then
'Adresse der oberen linken Zelle des Objekts
ZellAdr = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address
'Datei aus aktiver Zelle über Offset laden
'** hier bei x,y Zahlenwerte eingeben!!
sDatei = Range(ZellAdr).Offset(x, y).Value
sDatei = Range(ZellAdr).Offset(x, y) & ".pdf"
'Aussprung bei Fhler - keine Datei gefunden!
If sDatei = "" Then MsgBox "keine Datei gefunden": Exit Sub
sQuelle = "C:\Test\Prospekte\"
sZiel = "C.\Test\Versand\)"
If Dir(sZiel & sDatei) = "" Then
FileCopy sQuelle & sDatei, sZiel & sDatei
MsgBox "Datei wurde kopiert!"
Else
MsgBox "Datei war schon vorhanden!"
End If
End If
End Sub
'dieser Teil ist nur ein Demo Code zum finden des Offset(z,s)
Sub RichtigeZelle_finden()
Dim sQuelle$, sZiel$, sDatei$
Dim ZellAdr As String, j, s, z
'Adresse der oberen linken Zelle des Objekts
ZellAdr = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address(0, 0)
'MsgBox zum Testen der Zell Adresse!!
Range(ZellAdr).Select
MsgBox ZellAdr & " - das ist die obere linke Zelle der Kontroll Box"
'Offset mit Zahlen 0,1,2,3 austesten
'offset(0,x) verschiebt die Zelle nach rechts
'offset(y,0) verschiebt die Zelle nach unten
'offset(y,x) verschiebt die Zelle diagonal - nach rechts und unten
'für verschieben nach links -1, nach oben -1 - Offset(-1,-1)
On Error Resume Next
For j = 0 To 2
Range(ZellAdr).Offset(0, j).Select
MsgBox j & " " & Selection.Value & " Wert der Zelle nach rechts"
Next j
For j = 0 To 2
Range(ZellAdr).Offset(j, 0).Select
MsgBox j & " " & Selection.Value & " Wert der Zelle über unten"
Next j
For j = 0 To 2
Range(ZellAdr).Offset(0, -j).Select
MsgBox j & " " & Selection.Value & " Wert der Zelle nach links"
Next j
For j = 0 To 2
Range(ZellAdr).Offset(-j, 0).Select
MsgBox j & " " & Selection.Value & " Wert der Zelle über oben"
Next j
End Sub