Modul in Personal.xls übertragen
11.07.2017 15:40:15
Uwe222
Ich möchte Zellinhalte copieren, und dabei nicht die Spalten per Range("") oder cells(,) angeben,
sondern die Spaltenüberschriften dazu benutzen.
Quelle
| A | B | C | D | E | F | G | H | I | |
| 1 | Uwe 1 | Name E | Name H | ||||||
| 2 | EEEE | 22 | 222 | ||||||
| 3 | UUU | 33 | 333 | ||||||
| 4 |
Ziel
| A | B | C | D | E | F | G | H | |
| 1 | Name E | Name H | Uwe 2 | |||||
| 2 | ||||||||
| 3 | ||||||||
| 4 | ||||||||
| 5 |
Das hab ich so gelöst.
Modul1
Option Explicit
Sub Übertragen()
Dim AW
Dim TBQ, TBZ
Set TBQ = ActiveWorkbook.Sheets("Quelle")
Set TBZ = ActiveWorkbook.Sheets("Ziel")
AW = FindcopyH(TBQ, "Name E", 1, TBZ, "", 1, 3, 5)
AW = FindcopyH(TBQ, "Name H", 1, TBZ, "", 1, 3, 5)
'mit geänderter Überschrift
AW = FindcopyH(TBQ, "Uwe 1", 1, TBZ, "Uwe 2", 1, 2, 3)
'usw
If AW "" Then MsgBox "Fehler bereinigen"
End Sub
Option Explicit
Public QuellBlatt As Worksheet, ZielBlatt As Worksheet
Public QuellUeberschrift As String, ZielUeberschrift As String
Public QUebZeile As Integer, ZUebZeile As Integer
Public QCopyZeile As Long, ZCopyZeile As Long
Public Function FindcopyH(QuellBlatt, QuellUeberschrift, QUebZeile, _
ZielBlatt, ZielUeberschrift, ZUebZeile, _
QCopyZeile, ZCopyZeile)
On Error GoTo Fehler
Dim QSpalte As Integer, ZSpalte As Integer
'wenn Zielüberschrift="" dann gleich Quelle
ZielUeberschrift = IIf(ZielUeberschrift = "", QuellUeberschrift, ZielUeberschrift)
QUebZeile = IIf(QUebZeile = 0, 1, QUebZeile)
ZUebZeile = IIf(ZUebZeile = 0, 1, ZUebZeile)
'Spalten finden
QSpalte = WorksheetFunction.Match(QuellUeberschrift, QuellBlatt.Rows(QUebZeile), 0)
ZSpalte = WorksheetFunction.Match(ZielUeberschrift, ZielBlatt.Rows(ZUebZeile), 0)
'Übertragen
ZielBlatt.Cells(ZCopyZeile, ZSpalte) = QuellBlatt.Cells(QCopyZeile, QSpalte)
Exit Function
Fehler:
FindcopyH = "Fehler bei " & QuellUeberschrift
MsgBox FindcopyH
End Function
Ich übergebe die beiden Blattnamen, den/ die Spaltenkopfzeilen
und aus welcher Zeile ich in Welche übertragen will
1)
Hab es nur über eine Function hinbekommen, brauche eigendlich keinen Rückgabewert
2)
Das ganze Makro hätte ich gerne in der Personal.xlsb
3)
Wie kann ich Optionale Felder übergeben?
So in der Art FindcopyH(TBQ, "Name E",, TBZ,,, 3, 5)
also mit ,,
Fragen:
Wie mach ich das über ein normales Sub und Wie rufe ich das aus einer beliebigen Datei auf, wenn das Makro in der Personal steht?
Sollte jemand darüber hinaus noch Verbesserungen haben, bitte ebenfalls Info.
Danke im Vorraus, Uwe