AW: Werte von einer Mappe in eine andere Mappe kopiere
28.08.2013 19:13:06
einer
Hallo Franz und Hallo an alle,
dank Franz seiner Hilfe funktioniert das Makro super. Ich habe es ein wenig erweitert und würde nur gerne wissen ob das so ok ist oder ob man es einfacher machen kann. Es funktioniert so wie es soll, weil ich aber lernen möchte würde mich interessieren wie ihr Profis so etwas schreibt. Die fettgedruckten Zeilen habe ich gebastelt und der Rest, also das ordentliche ist vom Franz.
Sub Rechnung_fuellenTest()
Application.ScreenUpdating = False
Dim intZelle As Long, intCount As Integer, strText As String
Dim arrZellen As Variant
Dim wkbRechnung As Workbook, wksRechnung As Worksheet
Dim wksAktiv As Worksheet
Dim wksStart As Worksheet
Const strDatei = "C:\Users\marichen\Desktop\Excel_VBA Muster\Rechnung.xlsm"
'Zellen deren Inhalt übertragen werden soll
arrZellen = Array("S20", "S23", "S26", "S28", "S30", "S32", "S35", "S37")
ActiveSheet.Range("C2:D2", "C1").Copy
Set wksStart = Worksheets("Startseite")
wksStart.Range("P17").Copy
wksStart.Range("P18").Copy
wksStart.Range("P19").Copy
wksStart.Range("P21").Copy
Set wksAktiv = ActiveSheet
'Rechnungsdatei schreibgeschützt öffnen
Set wkbRechnung = Application.Workbooks.Open(Filename:=strDatei, ReadOnly:=True)
Set wksRechnung = wkbRechnung.Worksheets("Rechnung")
'Zellwerte übertragen
intCount = 0
For intZelle = 0 To UBound(arrZellen)
If wksAktiv.Range(arrZellen(intZelle)).Value > 0 Then
wksRechnung.Range("E14").Offset(intCount, 0).Value _
= wksAktiv.Range(arrZellen(intZelle)).Value
strText = ""
Select Case intZelle
Case 0: strText = "abc" 'S20 steht in Verbindung mit abc (feststehender Begriff)
Case 1: strText = "def" 'S23 steht in Verbindung mit def (feststehender Begriff)
Case 2: strText = "ghi" 'S26 "alle gleich wie in den ersten beiden beschrieben"
Case 3: strText = "jkl" 'S28
Case 4: strText = "mno" 'S30
Case 5: strText = "pqr" 'S32
Case 6: strText = "stu" 'S35
Case 7: strText = "vwx" 'S37
Case Else: strText = ""
End Select
If strText "" Then
With wksRechnung
wksRechnung.Range("B14:C14").Offset(intCount, 0).Value = strText
End With
End If
intCount = intCount + 1
End If
Next
wksRechnung.Range("E3") = wksAktiv.Range("C2") & "-" & wksAktiv.Range("D2")
wksRechnung.Range("E7") = wksAktiv.Range("C1")
wksRechnung.Range("E11") = wksStart.Range("P17")
wksRechnung.Range("E10") = wksStart.Range("P21")
wksRechnung.Range("E8") = wksStart.Range("P18")
wksRechnung.Range("E9") = wksStart.Range("P19")
Application.CutCopyMode = True
Set wksAktiv = Nothing
Set wkbRechnung = Nothing: Set wksRechnung = Nothing
Set wksStart = Nothing
End Sub
Danke für eure Mühe und Geduld mit mir
Luna