Office: Zellen kopieren

Helfe beim Thema Zellen kopieren in Microsoft Excel Hilfe um das Problem gemeinsam zu lösen; Hallo Aloys, die Datei ist noch geschlossen. Diese befindet sich nicht im selben Ordner. C:Eigene DateienRechnungenRechnungsnummer.xlsx C:Eigene... Dieses Thema im Forum "Microsoft Excel Hilfe" wurde erstellt von Macanudo, 5. Juni 2018.

Seite 3 von 4

MACANUDO

Macanudo

Zellen kopieren

Hallo Aloys,

die Datei ist noch geschlossen. Diese befindet sich nicht im selben Ordner.

C:Eigene DateienRechnungenRechnungsnummer.xlsx

C:Eigene DateienAllgemeinBauteile.xlsm

So ist die Ordnerstruktur.

Die 1. Abschlagrechnung ensteht, wenn ich das erste mal Bauteile aussuche und dann auf den Button Gesamtsumme drücke. Die 2. Abschlagrechnung ensteht, wenn ich weitere Bauteile aussuche und wieder auf Gesamtsumme drücke. usw.

Ich habe noch einen Code, der mir diese Rechnung als PDF in einen zu erstellenden Ordner kopiert. Am Am Ende könnte man dann einen Button aufmachen, der mich fragt, ob zurückgesetzt werden soll oder nicht. Der Code muss noch in einigen Kleinigkeiten angepasst werden ( Pfad und Zellen) aber so soll er aussehen.

Code:

Sub PDF()
Application.ScreenUpdating = False
Dim DateiPfad As String
Dim DateiName As String
Dim varNamArr As Variant
Dim intAnz As Integer
DateiPfad = "C:UsersritteBuchhaltungRechnungen " & Format(Now, "YYYY") & "" & Format(Now, "MMMM YYYY") & ""

If Dir(DateiPfad, vbDirectory) "" Then
Else
MkDir DateiPfad
End If
varNamArr = Array("Rechnung", "Rechnung")
Sheets("Rechnung").Select
For intAnz = 0 To 1
If Len(Sheets(varNamArr(intAnz)).Range("A26")) > 0 Then
DateiName = DateiPfad & Sheets(varNamArr(intAnz)).Range("F15") & " " & Sheets(varNamArr(intAnz)).Range("C6") & ".pdf"
Sheets(varNamArr(intAnz)).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
DateiName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End If
Next intAnz

Application.ScreenUpdating = True

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Vielen Dank.

Viele Grüße

Uwe

Macanudo, 14. Juni 2018

#31
ALOYS78

aloys78

Hallo Uwe,

Vorschlag zum 1. Teil; den entsprechenden Code durch den nachfolgenden austauschen.
In diesem Zusammenhang habe ich beim Kopieren das Format Buchhaltung an Stelle des bisherigen Formats Währung zugeordnet.
Code:

Option Explicit

' Version V3.4 vom 15.06.2018

Dim Q As Worksheet ' Quell-Tabelle
Dim Z As Worksheet ' Ziel-Tabelle
Dim button As MSForms.CommandButton

Dim LRowZ As Long ' letzte Zeile Ziel
Dim LRowZ2 As Long ' Zeilen# letzte Eintragung in Sp G
Dim r As Long ' Zeilen# in Ziel

Const zStart As Long = 4 ' Startzeile Ziel-Tabelle
Const ZSpalte As String = "A" ' Eintragen der gefilterten Daten ab dieser Spalte
Const nRows As Long = 4 ' Anzahl Leerzeilen nach der Zeile "Zwischensumme"
Const TxT As String = "Zwischensumme:"
Const TxTG As String = "Gesamtsumme:"
Const F_Buchhaltung = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Const RechnungsNR As String = "C:Eigene DateienRechnungenRechnungsnummer.xlsx"
' Const RechnungsNR As String = "D:AlleForenMS_Office_ForumUweRechnungsnummer.xlsx" ' nur für Test

Private Sub CommandButton1_Click()
'--------------------------------------------------------------------------------------------
' Endsumme bilden und ggf vorher schon vorhandene Endsumme als Zwischensumme ausweisen

' Version V3.4 vom 14.06.2018

'--------------------------------------------------------------------------------------------
Dim sw As Boolean
Dim Summe As Currency
Dim wbR As Workbook ' Workbook RechnungsNr
Dim wsR As Worksheet
Dim r2 As Long ' Zeilen# RechnungsNR

Set button = ActiveSheet.CommandButton1
Set Q = Worksheets("Tabelle1")
Set Z = Worksheets("Tabelle2")

With Z

' suche einen etwa vorhandenen Text "Zwischensumme" in Sp G
LRowZ = .Cells(Rows.Count, ZSpalte).End(xlUp).Row ' Zeilen# letzte Artikel#
For r = LRowZ To zStart Step -1
If .Range("G" & r) = TxT Then ' älteres Zwischenergebnia liegt vor
Summe = .Range("I" & r) ' letzte und aktuelle Zwischensumme
r = r + nRows ' Startzeile der Endergebnis
sw = True ' Schalter: True = älteres Zwischenergebnis liegt vor
Exit For
End If
Next r

' Startspalte wenn bisher noch keine Zwischensumme vorlag
If sw = False Then
r = zStart
Summe = 0
End If

' Endsumme bilden aus letzer Zwischensumme und den vorher eingegebenen Einzelpositionen
Summe = Summe + WorksheetFunction.Sum(.Range("I" & r & ":I" & LRowZ))

' Gesamtsumme ausgeben
r = LRowZ + 2
.Range("G" & r) = TxTG
.Range("I" & r) = Summe ' Gesamtsumme ohne Abzüge
.Range("I" & r).NumberFormat = F_Buchhaltung

' Abzüge darstellen
.Range("G" & r + 1) = IIf(Q.Range("iNachlass") = 0, "", Q.Range("iNachlass") * 100 & "% Nachlass") ' Nachlass
.Range("I" & r + 1) = IIf(Q.Range("iNachlass") = 0, 0, Q.Range("iNachlass") * Summe * (-1))
.Range("I" & r + 1).NumberFormat = F_Buchhaltung

.Range("G" & r + 2) = "0,3% Versicherung" ' Versicherung für Summe - Nachlass
.Range("I" & r + 2) = (Summe + .Range("I" & r + 1)) * -0.003
.Range("I" & r + 2).NumberFormat = F_Buchhaltung

.Range("G" & r + 3) = "10% AZ Einbehalt" ' AZ Eibehalt für Summe - Nachlass ' Versicherung
.Range("I" & r + 3) = (Summe + .Range("I" & r + 1)) * -0.1
.Range("I" & r + 3).NumberFormat = F_Buchhaltung

.Range("G" & r + 4) = "bereits gezahlt" ' bereits gezahlt ' Versicherung
.Range("I" & r + 4) = -Q.Range("iGezahlt")
.Range("I" & r + 4).NumberFormat = F_Buchhaltung

' Noch zu zahlen
.Range("G" & r + 5) = "noch zu zahlen" ' noch zu zahlen ' Versicherung
.Range("I" & r + 5) = WorksheetFunction.Sum(.Range("I" & r & ":I" & r + 4))
.Range("I" & r + 5).NumberFormat = F_Buchhaltung

' RechnungsNr eintragen
Application.ScreenUpdating = False
On Error Resume Next
Workbooks.Open Filename:=RechnungsNR
If Err.Number 0 Then
MsgBox RechnungsNR & " nicht gefunden !", vbCritical
On Error GoTo 0
GoTo Ende
End If
On Error GoTo 0
Set wbR = ActiveWorkbook
ThisWorkbook.Activate
Set wsR = wbR.Worksheets("Tabelle1")
r2 = wsR.Cells(Rows.Count, "B").End(xlUp).Row + 1
.Range("A2") = wsR.Range("A" & r2) ' Rechnungs#
wsR.Range("B" & r2) = .Range("A3") ' Name
.Range("I" & r + 5).Copy wsR.Range("C" & r2) ' Noch zu zahlen
Application.DisplayAlerts = False
wbR.Save
wbR.Close
Application.DisplayAlerts = True

'Abschlussarbeiten
Ende:
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set button = ActiveSheet.CommandButton1
button.Visible = False ' Button unsichtbar schalten
End With

MsgBox "Endsumme wurde " & IIf(sw = True, "neu ", "") & "gebildet !", vbInformation
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Beim 2. Teil Deines Beitrages sehe ich keine Beziehung zur Datei Bauteile.
Wie stellst Du Dir das Verfahren konkret vor ?

Gruß
Aloys

aloys78, 14. Juni 2018

#32
MACANUDO

Macanudo

Guten Morgen Aloys,

der erste Teil klappt sehr gut.

Meinst du mit dem 2. Teil das mit der Abschlagsrechnung?

Folgendes stellt sich mein Chef vor:

Ich suche mir Bauteile durch Doppelklick aus und drücke, wenn ich sie habe auf Gesamtsumme.

Er zieht mir die Rechnungsnummer, und dabei soll z.B. in Tabelle2 A6 stehen: "1. Abschlagsrechnung".

Jetzt kommen wieder Bauteile hinzu durch Doppelklick, diese werden wieder durch den Button Gesamtsumme eingetragen. Dann soll aus "1. Abschlagsrechnung" die "2. Abschlagsrechnung" werden. usw.

So, nun zum Speichern als PDF.

In die Datei Bauteile baue ich folgenden Code ein. Dieser speichert mir die Tabelle2 als PDF in einen variablen Ordner. Das funktioniert auch. Das werde ich vielleicht über einen Button in Tabelle2 lösen. Nun könnte man, wenn ich den Button gedrückt habe und die Tabelle2 als PDF gespeichert wurde, einen Hinweis anzeigen lassen, ob die Abschlagsrechnungen zurückgesetzt werden sollen, oder nicht.

Ich schicke Dir noch einmal den PDF Code mit.

Code:

Sub PDF()
Application.ScreenUpdating = False
Dim DateiPfad As String
Dim DateiName As String
Dim varNamArr As Variant
Dim intAnz As Integer
DateiPfad = "C:UsersritteBuchhaltungRechnungen " & Format(Now, "YYYY") & "" & Format(Now, "MMMM YYYY") & ""

If Dir(DateiPfad, vbDirectory) "" Then
Else
MkDir DateiPfad
End If
varNamArr = Array("Tabelle2", "Tabelle2")
Sheets("Tabelle2").Select
For intAnz = 0 To 1
If Len(Sheets(varNamArr(intAnz)).Range("A2")) > 0 Then
DateiName = DateiPfad & Sheets(varNamArr(intAnz)).Range("A2") & " " & Sheets(varNamArr(intAnz)).Range("A3") & ".pdf"
Sheets(varNamArr(intAnz)).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
DateiName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End If
Next intAnz

Application.ScreenUpdating = True

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Vielen Dank.

Viele Grüße

Uwe

Macanudo, 14. Juni 2018

#33
ALOYS78

aloys78

Zellen kopieren

Hallo Uwe,

Meinst du mit dem 2. Teil das mit der Abschlagsrechnung?
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Nein - das Thema hattest Du bisher überhaupt noch nicht angesprochen !

Er zieht mir die Rechnungsnummer, und dabei soll z.B. in Tabelle2 A6 stehen: "1. Abschlagsrechnung".
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

1. Ist dieses Thema neu !
2. Wieso nach A6 ? Da stehen doch Daten !

Nun könnte man, wenn ich den Button gedrückt habe und die Tabelle2 als PDF gespeichert wurde, einen Hinweis anzeigen lassen, ob die Abschlagsrechnungen zurückgesetzt werden sollen, oder nicht.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Ja !
Das dürftest Du aber alleine hinkriegen !

Gruß
Aloys

aloys78, 14. Juni 2018

#34
MACANUDO

Macanudo

Hallo Aloys,

oh je, was meinst du dann mit dem 2. Teil? Da bin ich jetzt verwirrt.

Das mit der "Abschlagsrechnung" hatte ich in #29 angesprochen, ist vielleicht nicht so richtig rübergekommen. Es soll keine richtige Abschlagsrechnung sein, sondern nur eine Information in einer Zelle.

Die Zellenangabe "A6" war nur beispielhaft, da können wir auch "G1" nehmen.

Es geht mir bei der Angabe mit der Abschlagsrechnung darum, dass es hochzählt und wenn ich den Button drücke, dass es wieder auf Null gesetzt wird. Da scheitert es bei mir.

Button erstellen und den mit Leben füllen, das bekomme ich hin. Nur halt nicht, dieses hochzählen und dann auf 0 setzen.

Hoffentlich konnte ich etwas Licht ins Dunkle bringen.

Vielen Dank.

Viele Grüße

Uwe

Macanudo, 15. Juni 2018

#35
MACANUDO

Macanudo

Hallo Aloys,

das mit dem Hochzählen habe ich jetzt anders gelöst. Konnte mich an eine alte Datei von mir entsinnen, da hatte ich ein ähnliches Problem. Ich habe es mit folgendem Code gelöst.

Code:

Sub zählen()
Dim x As Range
Set x = Sheets("Tabelle1").Range("G1")
x = x + 1
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Den Rest werde ich jetzt anpassen und mir einen Button schmieden.

Vielen lieben Dank für Deine unendliche Geduld.

Viele Grüße

Uwe

Macanudo, 15. Juni 2018

#36
MACANUDO

Macanudo

Guten Morgen Aloys,

ich setze das Thema noch einmal auf unerledigt.

Bei der Arbeit ist mir aufgefallen, dass es manchmal Rundungsfehler gibt, da er alle Stellen nach dem Komma mit auf das andere Tabellenblatt überträgt. Jetzt hatte ich versucht mit .Round etwas hinzubekommen, leider mit keinem Erfolg.

Es geht bei dem Fall um den im Code bezeichneten Abschnitt "Abzüge darstellen".

Noch etwas: ist es möglich, wenn bei Nachlass und bereits gezahlt eine 0 steht, dass diese Zeile ausgeblendet wird? Also nur, wenn du nicht den gesamten Code umschreiben musst.

Vielen Dank.

Viele Grüße

Uwe

Anbei der Code. Dieser habe ich schon so angepasst, dass er auf meinem System läuft.

Code:

Option Explicit

' Version V3.4 vom 15.06.2018

Dim Q As Worksheet ' Quell-Tabelle
Dim Z As Worksheet ' Ziel-Tabelle
Dim button As MSForms.CommandButton

Dim LRowZ As Long ' letzte Zeile Ziel
Dim LRowZ2 As Long ' Zeilen# letzte Eintragung in Sp G
Dim r As Long ' Zeilen# in Ziel

Const zStart As Long = 16 ' Startzeile Ziel-Tabelle
Const ZSpalte As String = "A" ' Eintragen der gefilterten Daten ab dieser Spalte
Const nRows As Long = 2 ' Anzahl Leerzeilen nach der Zeile "Zwischensumme"
Const TxT As String = "Zwischensumme:"
Const TxTG As String = "Gesamtsumme:"
Const F_Buchhaltung = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
'Const RechnungsNR As String = "C:UsersritteSvenAllgemeinRechnungsnummer.xlsx"
Const RechnungsNR As String = "C:Usersh1504uzDesktopRechnungsnummer.xlsx"

Private Sub CommandButton1_Click()
'--------------------------------------------------------------------------------------------
' Endsumme bilden und ggf vorher schon vorhandene Endsumme als Zwischensumme ausweisen

' Version V3.4 vom 14.06.2018

'--------------------------------------------------------------------------------------------
Dim sw As Boolean
Dim Summe As Currency
Dim wbR As Workbook ' Workbook RechnungsNr
Dim wsR As Worksheet
Dim r2 As Long ' Zeilen# RechnungsNR
Dim x As Range

Set button = ActiveSheet.CommandButton1
Set Q = Worksheets("LV")
Set Z = Worksheets("Rechnung")
Set x = Sheets("LV").Range("C12")
With Z

' suche einen etwa vorhandenen Text "Zwischensumme" in Sp G
LRowZ = .Cells(Rows.Count, ZSpalte).End(xlUp).Row ' Zeilen# letzte Artikel#
For r = LRowZ To zStart Step -1
If .Range("C" & r) = TxT Then ' älteres Zwischenergebnia liegt vor
Summe = .Range("G" & r) ' letzte und aktuelle Zwischensumme
r = r + nRows ' Startzeile der Endergebnis
sw = True ' Schalter: True = älteres Zwischenergebnis liegt vor
Exit For
End If
Next r

' Startspalte wenn bisher noch keine Zwischensumme vorlag
If sw = False Then
r = zStart
Summe = 0
End If

' Endsumme bilden aus letzer Zwischensumme und den vorher eingegebenen Einzelpositionen
Summe = Summe + WorksheetFunction.Sum(.Range("G" & r & ":G" & LRowZ))

' Gesamtsumme ausgeben
r = LRowZ + 2
.Range("C" & r) = TxTG
.Range("C" & r).HorizontalAlignment = xlLeft
.Range("G" & r) = Summe ' Gesamtsumme ohne Abzüge
.Range("G" & r).NumberFormat = F_Buchhaltung

' Abzüge darstellen
.Range("C" & r + 1) = IIf(Q.Range("iNachlass") = 0, "", Q.Range("iNachlass") * 1 & "% Nachlass") ' Nachlass
.Range("C" & r + 1).HorizontalAlignment = xlLeft
.Range("G" & r + 1) = IIf(Q.Range("iNachlass") = 0, 0, Q.Range("iNachlass") * Summe * (-0.01))
.Range("G" & r + 1).NumberFormat = F_Buchhaltung

.Range("C" & r + 2) = IIf(Q.Range("iNachlass1") = 0, "", Q.Range("iNachlass1") * 1 & "% Versicherung") ' Nachlass
.Range("C" & r + 2).HorizontalAlignment = xlLeft
.Range("G" & r + 2) = IIf(Q.Range("iNachlass1") = 0, 0, (Summe + .Range("G" & r + 1)) * -Q.Range("iNachlass1") * -(-0.01))
.Range("G" & r + 2).NumberFormat = F_Buchhaltung

.Range("C" & r + 3) = IIf(Q.Range("iNachlass2") = 0, "", Q.Range("iNachlass2") * 1 & "% AZ Einbehalt") ' AZ Eibehalt für Summe - Nachlass ' Versicherung
.Range("C" & r + 3).HorizontalAlignment = xlLeft
.Range("G" & r + 3) = IIf(Q.Range("iNachlass2") = 0, 0, (Summe + .Range("G" & r + 1)) * -0.1)
.Range("G" & r + 3).NumberFormat = F_Buchhaltung

.Range("C" & r + 4) = IIf(Q.Range("iGezahlt") = 0, "", "bereits gezahlt") ' bereits gezahlt ' Versicherung
.Range("C" & r + 4).HorizontalAlignment = xlLeft
.Range("G" & r + 4) = IIf(Q.Range("iGezahlt") = 0, 0, -Q.Range("iGezahlt"))
.Range("G" & r + 4).NumberFormat = F_Buchhaltung

' Noch zu zahlen
.Range("C" & r + 5) = "Netto" ' noch zu zahlen ' Versicherung
.Range("C" & r + 5).HorizontalAlignment = xlLeft
' .Range("C" & r + 5).Font.Bold = True
.Range("G" & r + 5) = WorksheetFunction.Sum(.Range("G" & r & ":G" & r + 4))
.Range("G" & r + 5).NumberFormat = F_Buchhaltung
'.Range("G" & r + 5).Font.Bold = True

.Range("C" & r + 6) = "zzgl. 19% MwSt.:" ' Versicherung für Summe - Nachlass
.Range("C" & r + 6).HorizontalAlignment = xlLeft
.Range("G" & r + 6) = (.Range("G" & r + 5)) * 0.19
.Range("G" & r + 6).NumberFormat = F_Buchhaltung

.Range("C" & r + 7) = "noch zu zahlen" ' noch zu zahlen ' Versicherung
.Range("C" & r + 7).HorizontalAlignment = xlLeft
.Range("C" & r + 7).Font.Bold = True
.Range("G" & r + 7) = (.Range("G" & r + 5) + (.Range("G" & r + 6)))
.Range("G" & r + 7).NumberFormat = F_Buchhaltung
.Range("G" & r + 7).Font.Bold = True

' RechnungsNr eintragen
Application.ScreenUpdating = False
On Error Resume Next
Workbooks.Open Filename:=RechnungsNR
If Err.Number 0 Then
MsgBox RechnungsNR & " nicht gefunden !", vbCritical
On Error GoTo 0
GoTo Ende
End If
On Error GoTo 0
x = x + 1

Set wbR = ActiveWorkbook
ThisWorkbook.Activate
Set wsR = wbR.Worksheets("Tabelle1")
r2 = wsR.Cells(Rows.Count, "B").End(xlUp).Row + 1
.Range("C1") = wsR.Range("A" & r2) ' Rechnungs#
wsR.Range("B" & r2) = .Range("A3") ' Firma
wsR.Range("C" & r2) = .Range("F1") ' Objekt
wsR.Range("E" & r2) = .Range("F6") ' Abschlagsrechnung
.Range("G" & r + 5).Copy wsR.Range("D" & r2) ' Noch zu zahlen
Application.DisplayAlerts = False
wbR.Save
wbR.Close
Application.DisplayAlerts = True

'Abschlussarbeiten
Ende:
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set button = ActiveSheet.CommandButton1
button.Visible = False ' Button unsichtbar schalten
End With

MsgBox "Endsumme wurde " & IIf(sw = True, "neu ", "") & "gebildet !", vbInformation
Sheets("Rechnung").Select
'Call Zeile
'Call PDF
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'--------------------------------------------------------------------------------------------
' angeklickte Zeile aus Quell-Tabelle in Ziel-Tabelle kopieren
'
' Version V3 vom 12.06.2018
'
'--------------------------------------------------------------------------------------------
Dim LRowQ As Long ' letzte Zeile Quelle
Dim c As Long ' Spalten#
Const QSpalte As Long = 1 ' Start-Spalte Quelle
Const nSpalten As Long = 7 ' Anzahl daneben liegender Spalten, aus denen die Inhalte in die Zieldatei
' übertragen werden sollener Tabelle mit den Quelldaten
' Initialisierung
Set Q = Worksheets("LV") ' Quell-Tabelle
Set Z = Worksheets("Rechnung") ' Ziel-Tabelle

With Q
LRowQ = .Cells(Rows.Count, QSpalte).End(xlUp).Row ' letzte Zeile in Quelle
If Intersect(Target, .Range(.Cells(2, QSpalte), .Cells(LRowQ, QSpalte))) Is Nothing Then Exit Sub ' Click nicht in Sp A
Cancel = True
LRowZ = Z.Cells(Rows.Count, ZSpalte).End(xlUp).Row ' Zeilen# letzte Artikel# in Ziel Sp A
LRowZ2 = Z.Cells(Rows.Count, "C").End(xlUp).Row ' Zeilen# letzte Eintragung in Ziel Sp G

' check Status Ziel-Tabelle
If LRowZ < zStart Then ' Ziel-Tabelle noch ohne Eintrag
r = zStart

ElseIf LRowZ2 > LRowZ Then ' letzte Zeile ist Gesamtsumme (Sp G enthält mehr Einträge als Sp A)
With Z
r = LRowZ2 - 7
.Range("C" & r + 1 & ":G" & LRowZ2).ClearContents ' bisherige Daten für Gesamtsumme löschen
.Range("C" & r + 1 & ":G" & LRowZ2).HorizontalAlignment = xlRight ' Daten mittig ausrichten
.Range("C" & r) = TxT ' Text Gesamtsumme durch Zwischensumme ersetzen
.Range("C" & LRowZ2).Font.Bold = False
.Range("G" & LRowZ2).Font.Bold = False ' Fett entfernen
r = r + nRows
End With

Else ' letzte Zeile = Tabelle schon mit Daten, aber noch ohne Gesamtsumme
r = LRowZ + 1
End If

' kopierte Quellzeile einfügen
For c = 1 To 7
.Cells(Target.Row, c * 1).Copy Z.Cells(r, c * 1)
Next c
Application.CutCopyMode = False

' Button für Bildung der Summe sichtbar machen
Set button = ActiveSheet.CommandButton1
button.Visible = True
End With

' Nachricht
MsgBox "Artikel " & Target.Value & " wurde kopiert !", vbInformation
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Macanudo, 26. Juni 2018

#37
ALOYS78

aloys78

Zellen kopieren

Hallo Uwe,

Bei der Arbeit ist mir aufgefallen, dass es manchmal Rundungsfehler gibt, da er alle Stellen nach dem Komma mit auf das andere Tabellenblatt überträgt.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Kannst Du mal ein Beispiel aufzeigen, anhand dessen man nachvollziehen kann, wo und wie diese Rundungsunterschiede heute entstehen und wie es aus Deiner Sicht aber aussehen soll.

Gruß
Aloys

aloys78, 26. Juni 2018

#38
MACANUDO

Macanudo

Hallo Aloys,

anbei die Datei. Im Blatt "Rechnung", bei der Versicherung, übernimmt er in G24 4,455 Euro. Er zeigt zwar 4,46 an, aber bei der Berechnung weiter unten ist eine Verschiebung drin. Die 4.456 sieht man, wenn die Zelle angeklickt wurde. In der Datei rot dargestellt, so wie es aussehen sollte.

Wahrscheinlich nimmt der Code den ungerundeten Teil von der Versicherung und rechnet mit allen Nachkommastellen weiter.

Dadurch verschiebt sich das bis zum Endbetrag.

Vielen Dank.

Viele Grüße

Uwe

Macanudo, 26. Juni 2018

#39
ALOYS78

aloys78

Hallo Uwe,

Vorschlag (ungetestet)
Code:

.Range("C" & r + 2) = IIf(Q.Range("iNachlass1") = 0, "", Q.Range("iNachlass1") * 1 & "% Versicherung") ' Versicherung
.Range("C" & r + 2).HorizontalAlignment = xlLeft
.Range("G" & r + 2) = IIf(Q.Range("iNachlass1") = 0, 0, (Summe + .Range("G" & r + 1)) * -Q.Range("iNachlass1") * -(-0.01))
.Range("G" & r + 2) = WorksheetFunction.Round(.Range("G" & r + 2), 2)
.Range("G" & r + 2).NumberFormat = F_Buchhaltung
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Gruß
Aloys

aloys78, 27. Juni 2018

#40
MACANUDO

Macanudo

Guten Morgen Aloys,

vielen Dank für Deine Hilfe. Das klappt wieder super. Hatte es ohne die Worksheet.Function probiert. Hatte nur .Round eingesetzt.

Ich habe unten noch einen Code, der mir die Zeilen ausblendet, die eine 0 in der Spalte "G"enthalten.

Gibt eine Möglichkeit, dass er nur in dem Bereich zwischen "Gesamtsumme" und "noch zu zahlen" in Spalte C, Sheet "Rechnung"sucht? Die Zeilen ändern sich ja immer, wenn ich etwas hinzufüge.

Vielen Dank.

Viele Grüße

Uwe

Code:

Sub ausblenden()

Dim zeile As Integer
zeile = 182
For zeile = 182 To 188
If Range("G" & zeile).Value = "0" Then
Rows(zeile).Hidden = True
Else
End If
Next zeile
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Macanudo, 27. Juni 2018

#41
ALOYS78

aloys78

Hallo Uwe,

Gibt eine Möglichkeit, dass er nur in dem Bereich zwischen "Gesamtsumme" und "noch zu zahlen" in Spalte C, Sheet "Rechnung"sucht? Die Zeilen ändern sich ja immer, wenn ich etwas hinzufüge.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Im Beitrag zuvor hattest Du geschrieben, Nachlass und schon gezahlt ausblenden, wenn 0.
Hast Du Dir es anders überlegt ?

Gruß
Aloys

aloys78, 27. Juni 2018

#42
MACANUDO

Macanudo

Zellen kopieren

Hallo Aloys,

im Prinzip sind es die beiden Positionen. Aber es kann auch sein, dass die 10% AZ Einbehalt und die Versicherung mal wegfallen. Deshalb das mit dem Bereich. Hoffe, dass es nicht zu kompliziert macht.

Vielen Dank.

Viele Grüße

Uwe

Macanudo, 27. Juni 2018

#43
ALOYS78

aloys78

Hallo Uwe,

die Kandidaten sind also: Nachlass, schon gezahlt, AZ Einbehalt, Versicherung.

Hoffe, dass es nicht zu kompliziert macht.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Glaube ich im Moment nicht.
Allerdings liegt das Problem im Detail; wenn es zB schon einen Gesamtsumme-Block gab, dann sind dort etwa ausgeblendete Zeilen wieder einzublenden.

Gruß
Aloys

aloys78, 27. Juni 2018

#44
MACANUDO

Macanudo

Hallo Aloys,

genau, das sind die Kandidaten.

Ich wusste doch, dass es wieder tiefgreifender wird, als ich es mir gedacht hatte.

Anbei der aktuell, angepasste Code der zur Zeit bei mir funktioniert.

Vielen Dank.

Viele Grüße Uwe

Code:

Option Explicit

' Version V3.4 vom 15.06.2018

Dim Q As Worksheet ' Quell-Tabelle
Dim Z As Worksheet ' Ziel-Tabelle
Dim button As MSForms.CommandButton

Dim LRowZ As Long ' letzte Zeile Ziel
Dim LRowZ2 As Long ' Zeilen# letzte Eintragung in Sp G
Dim r As Long ' Zeilen# in Ziel

Const zStart As Long = 16 ' Startzeile Ziel-Tabelle
Const ZSpalte As String = "A" ' Eintragen der gefilterten Daten ab dieser Spalte
Const nRows As Long = 2 ' Anzahl Leerzeilen nach der Zeile "Zwischensumme"
Const TxT As String = "Zwischensumme:"
Const TxTG As String = "Gesamtsumme:"
Const F_Buchhaltung = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
'Const RechnungsNR As String = "C:UsersritteSvenAllgemeinRechnungsnummer.xlsx"
Const RechnungsNR As String = "C:Usersh1504uzDesktopRechnungsnummer.xlsx"

Private Sub CommandButton1_Click()
'--------------------------------------------------------------------------------------------
' Endsumme bilden und ggf vorher schon vorhandene Endsumme als Zwischensumme ausweisen

' Version V3.4 vom 14.06.2018

'--------------------------------------------------------------------------------------------
Dim sw As Boolean
Dim Summe As Currency
Dim wbR As Workbook ' Workbook RechnungsNr
Dim wsR As Worksheet
Dim r2 As Long ' Zeilen# RechnungsNR
Dim x As Range

Set button = ActiveSheet.CommandButton1
Set Q = Worksheets("LV")
Set Z = Worksheets("Rechnung")
Set x = Sheets("LV").Range("C12")
With Z

' suche einen etwa vorhandenen Text "Zwischensumme" in Sp G
LRowZ = .Cells(Rows.Count, ZSpalte).End(xlUp).Row ' Zeilen# letzte Artikel#
For r = LRowZ To zStart Step -1
If .Range("C" & r) = TxT Then ' älteres Zwischenergebnia liegt vor
Summe = .Range("G" & r) ' letzte und aktuelle Zwischensumme
r = r + nRows ' Startzeile der Endergebnis
sw = True ' Schalter: True = älteres Zwischenergebnis liegt vor
Exit For
End If
Next r

' Startspalte wenn bisher noch keine Zwischensumme vorlag
If sw = False Then
r = zStart
Summe = 0
End If

' Endsumme bilden aus letzer Zwischensumme und den vorher eingegebenen Einzelpositionen
Summe = Summe + WorksheetFunction.Sum(.Range("G" & r & ":G" & LRowZ))

' Gesamtsumme ausgeben
r = LRowZ + 2
.Range("C" & r) = TxTG
.Range("C" & r).HorizontalAlignment = xlLeft
.Range("G" & r) = Summe ' Gesamtsumme ohne Abzüge
.Range("G" & r) = WorksheetFunction.Round(.Range("G" & r), 2)
.Range("G" & r).NumberFormat = F_Buchhaltung

' Abzüge darstellen
.Range("C" & r + 1) = IIf(Q.Range("iNachlass") = 0, "Nachlass", Q.Range("iNachlass") * 1 & "% Nachlass") ' Nachlass
.Range("C" & r + 1).HorizontalAlignment = xlLeft
.Range("G" & r + 1) = IIf(Q.Range("iNachlass") = 0, 0, Q.Range("iNachlass") * Summe * (-0.01))
.Range("G" & r + 1) = WorksheetFunction.Round(.Range("G" & r + 1), 2)
.Range("G" & r + 1).NumberFormat = F_Buchhaltung

.Range("C" & r + 2) = IIf(Q.Range("iNachlass1") = 0, "Bauwesenversicherung", Q.Range("iNachlass1") * 1 & "% Versicherung") ' Nachlass
.Range("C" & r + 2).HorizontalAlignment = xlLeft
.Range("G" & r + 2) = (Summe + .Range("G" & r + 1)) * -Q.Range("iNachlass1") * -(-0.01)
.Range("G" & r + 2) = WorksheetFunction.Round(.Range("G" & r + 2), 2)
.Range("G" & r + 2).NumberFormat = F_Buchhaltung

.Range("C" & r + 3) = "10% AZ Einbehalt" ' AZ Eibehalt für Summe - Nachlass ' Versicherung
.Range("C" & r + 3).HorizontalAlignment = xlLeft
.Range("G" & r + 3) = (Summe + .Range("G" & r + 1)) * -0.1
.Range("G" & r + 3) = WorksheetFunction.Round(.Range("G" & r + 3), 2)
.Range("G" & r + 3).NumberFormat = F_Buchhaltung

.Range("C" & r + 4) = "bereits gezahlt" ' bereits gezahlt ' Versicherung
.Range("C" & r + 4).HorizontalAlignment = xlLeft
.Range("G" & r + 4) = -Q.Range("iGezahlt")
.Range("G" & r + 4) = WorksheetFunction.Round(.Range("G" & r + 4), 2)
.Range("G" & r + 4).NumberFormat = F_Buchhaltung

' Noch zu zahlen
.Range("C" & r + 5) = "noch zu zahlen" ' noch zu zahlen ' Versicherung
.Range("C" & r + 5).HorizontalAlignment = xlLeft
.Range("C" & r + 5).Font.Bold = True
.Range("G" & r + 5) = WorksheetFunction.Sum(.Range("G" & r & ":G" & r + 4))
.Range("G" & r + 5) = WorksheetFunction.Round(.Range("G" & r + 5), 2)
.Range("G" & r + 5).NumberFormat = F_Buchhaltung
.Range("G" & r + 5).Font.Bold = True

' RechnungsNr eintragen
Application.ScreenUpdating = False
On Error Resume Next
Workbooks.Open Filename:=RechnungsNR
If Err.Number 0 Then
MsgBox RechnungsNR & " nicht gefunden !", vbCritical
On Error GoTo 0
GoTo Ende
End If
On Error GoTo 0
x = x + 1

Set wbR = ActiveWorkbook
ThisWorkbook.Activate
Set wsR = wbR.Worksheets("Tabelle1")
r2 = wsR.Cells(Rows.Count, "B").End(xlUp).Row + 1
.Range("C1") = wsR.Range("A" & r2) ' Rechnungs#
wsR.Range("B" & r2) = .Range("A3") ' Firma
wsR.Range("C" & r2) = .Range("F1") ' Objekt
wsR.Range("E" & r2) = .Range("F6") ' Abschlagsrechnung
.Range("G" & r + 5).Copy wsR.Range("D" & r2) ' Noch zu zahlen
Application.DisplayAlerts = False
wbR.Save
wbR.Close
Application.DisplayAlerts = True

'Abschlussarbeiten
Ende:
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set button = ActiveSheet.CommandButton1
button.Visible = False ' Button unsichtbar schalten
End With

MsgBox "Endsumme wurde " & IIf(sw = True, "neu ", "") & "gebildet !", vbInformation
Sheets("Rechnung").Select
Call Zeile
Call PDF
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'--------------------------------------------------------------------------------------------
' angeklickte Zeile aus Quell-Tabelle in Ziel-Tabelle kopieren
'
' Version V3 vom 12.06.2018
'
'--------------------------------------------------------------------------------------------
Dim LRowQ As Long ' letzte Zeile Quelle
Dim c As Long ' Spalten#
Const QSpalte As Long = 1 ' Start-Spalte Quelle
Const nSpalten As Long = 7 ' Anzahl daneben liegender Spalten, aus denen die Inhalte in die Zieldatei
' übertragen werden sollener Tabelle mit den Quelldaten
' Initialisierung
Set Q = Worksheets("LV") ' Quell-Tabelle
Set Z = Worksheets("Rechnung") ' Ziel-Tabelle

With Q
LRowQ = .Cells(Rows.Count, QSpalte).End(xlUp).Row ' letzte Zeile in Quelle
If Intersect(Target, .Range(.Cells(2, QSpalte), .Cells(LRowQ, QSpalte))) Is Nothing Then Exit Sub ' Click nicht in Sp A
Cancel = True
LRowZ = Z.Cells(Rows.Count, ZSpalte).End(xlUp).Row ' Zeilen# letzte Artikel# in Ziel Sp A
LRowZ2 = Z.Cells(Rows.Count, "C").End(xlUp).Row ' Zeilen# letzte Eintragung in Ziel Sp G

' check Status Ziel-Tabelle
If LRowZ < zStart Then ' Ziel-Tabelle noch ohne Eintrag
r = zStart

ElseIf LRowZ2 > LRowZ Then ' letzte Zeile ist Gesamtsumme (Sp G enthält mehr Einträge als Sp A)
With Z
r = LRowZ2 - 5
.Range("C" & r + 1 & ":G" & LRowZ2).ClearContents ' bisherige Daten für Gesamtsumme löschen
.Range("C" & r + 1 & ":G" & LRowZ2).HorizontalAlignment = xlRight ' Daten mittig ausrichten
.Range("C" & r) = TxT ' Text Gesamtsumme durch Zwischensumme ersetzen
.Range("C" & LRowZ2).Font.Bold = False
.Range("G" & LRowZ2).Font.Bold = False ' Fett entfernen
r = r + nRows
End With

Else ' letzte Zeile = Tabelle schon mit Daten, aber noch ohne Gesamtsumme
r = LRowZ + 1
End If

' kopierte Quellzeile einfügen
For c = 1 To 7
.Cells(Target.Row, c * 1).Copy Z.Cells(r, c * 1)
Next c
Application.CutCopyMode = False

' Button für Bildung der Summe sichtbar machen
Set button = ActiveSheet.CommandButton1
button.Visible = True
End With

' Nachricht
MsgBox "Artikel " & Target.Value & " wurde kopiert !", vbInformation
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Macanudo, 27. Juni 2018

#45

(Du musst angemeldet oder registriert sein, um eine Antwort erstellen zu können.)

Seite 3 von 4

Thema:

Zellen kopieren

Die Seite wird geladen...

Zellen kopieren - Similar Threads - Zellen kopieren
Nur markierte Zellen kopieren und wieder einfügen
in Microsoft Excel Hilfe
Nur markierte Zellen kopieren und wieder einfügen: Ich habe z.B. in einer Excelliste untereinander folgendes stehen: 1 2 3 4 5 Ich markiere mir nun anhand folgender Tastenkombination (Strg gedrückt halten) alle Zellen, außer Zelle 2. Nun...
Zellen aus Aktiver Zeile kopieren
in Microsoft Excel Hilfe
Zellen aus Aktiver Zeile kopieren: Hallo zusammen, im Grunde genommen ist es wohl ganz einfach … ich weiss es aber trotzdem nicht wie es in VBA umsetze. Ich will aus einer „Aktiven Reihe“ (diese wähle ich vorher über einen...
Excel VBA - Code Hilfe (Spalten, Werte kopieren etc.)
in Microsoft Excel Hilfe
Excel VBA - Code Hilfe (Spalten, Werte kopieren etc.): Hallo, ich benötige Hilfe für ein Problem, welches ich leider selbst schwerlich als Anfänger nicht lösen kann: Ich möchte von dem Tabellenblatt "Tabelle1" aus den Zellen B8:B14, K8:K14, B18:B25,...
Wert einer Zelle kopieren wenn..
in Microsoft Excel Hilfe
Wert einer Zelle kopieren wenn..: Hallo zusammen, ich möchte folgendes in Excel erreichen: Beispiel: Wenn der Wert von A1 = 1 ist, dann soll der Wert aus Zelle A2 in Zelle A3 kopiert werden Wie bekomme ich das hin. Vielen Dank
Wenn in Zelle bestimmter Wert dann kopieren
in Microsoft Excel Hilfe
Wenn in Zelle bestimmter Wert dann kopieren: Hallo, ich bin absolut neu was Excel angeht und suche eine Lösung für mein Problem. Ich habe zwei Arbeitsblätter ("Übersicht Zimmer & "Bereiche") mit Haushaltsaufgaben und deren Turnus. Nun...
Textausgabe eines Formelergebnisses in anderer Zelle
in Microsoft Excel Hilfe
Textausgabe eines Formelergebnisses in anderer Zelle: Liebe Excel-Expert:innen Ich benötige für die Weiterverarbeitung eines Excel-Files in einem anderen Programm reine Textzellen. Das heisst, die unten stehenden Formel (B2) soll in der Zelle A2 als...
Zellen automatisch in ein neues Blatt kopieren wenn
in Microsoft Excel Hilfe
Zellen automatisch in ein neues Blatt kopieren wenn: Hallo zusammen, ich habe eine Tabelle (Tabelle1) in der regelmäßig neue Kunden eingetragen werden. Kd.-Nr. / Kundendaten / Flyer erhalten / etc. In der Spalte (Flyer erhalten) wird "ja"...

Anmelden oder registrieren

Suche

Diese Seite verwendet Cookies, um Inhalte zu personalisieren, diese deiner Erfahrung anzupassen und dich nach der Registrierung angemeldet zu halten.
Auf dieser Website werden Cookies für die Zugriffsanalyse und Anzeigenmessung verwendet.
Wenn du dich weiterhin auf dieser Seite aufhältst, akzeptierst du unseren Einsatz von Cookies.

Akzeptieren Weitere Informationen...

Information ausblenden