Office: Suchen und Summe bilden

Helfe beim Thema Suchen und Summe bilden in Microsoft Excel Hilfe um das Problem gemeinsam zu lösen; Moin Ich hab mal die Spaltenbuchstaben verwendet. Fuer dich besser lesbar. Code: Sub holen_Umwandeln() '-- holt die Daten aus der(wenn geoeffneten)... Dieses Thema im Forum "Microsoft Excel Hilfe" wurde erstellt von User, 8. Dezember 2019.

Seite 3 von 5

HARY

hary

Suchen und Summe bilden

Moin
Ich hab mal die Spaltenbuchstaben verwendet. Fuer dich besser lesbar.
Code:

Sub holen_Umwandeln()
'-- holt die Daten aus der(wenn geoeffneten) Mappe "DE****"
Dim wbk As Workbook
Dim lngLetzeZeile As Long
Dim offen As Boolean
Application.ScreenUpdating = False '--Bildschirmflackern ausschalten
lngLetzeZeile = Cells(Rows.Count, "C").End(xlUp).Row
'--loescht alte Daten
Range(Cells(29, "A"), Cells(lngLetzeZeile, "P")).Clear '-- A bis P loeschen
'--kopiert Daten und fuegt diese ein, wenn Mappe "DE**" geoeffnet
For Each wbk In Workbooks '--Schleife ueber geoeffnete Mappen
If wbk.Name Like "DE*" Then '--wenn Mappenname beginnt mit DE
With Workbooks(wbk.Name).Worksheets("Sheet1") '--ggf. Blattname anpassen
.Range("C1:C5").Copy Cells(1, "C")
.Range("D1:D5").Copy Cells(1, "D")
.Range("A29:I" & .Cells(.Rows.Count, "C").End(xlUp).Row).Copy Cells(29, "A")
Application.CutCopyMode = False
End With
offen = True
Exit For '--Schleife beenden
End If
Next
If Not offen Then '--wenn betr. Mappe nicht offen
MsgBox "passende Mappe nicht offen", vbCritical, "Hinweis"
Exit Sub '--Makro beenden
End If
'--umwandeln Text in Zahl
Range("H29:H" & Cells(Rows.Count, "C").End(xlUp).Row).TextToColumns Destination:=Range("H29"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'--zieht die Formeln runter
Range("J28:N28").AutoFill Destination:=Range("J28:N" & Cells(Rows.Count, "C").End(xlUp).Row), Type:=xlFillDefault
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

gruss hary

hary, 16. Dezember 2019

#31
USER

User

Super geht, danke auch für die Beschreibung was passiert!

Du hast mit sehr geholfen!

DANKESCHÖN!!

User, 16. Dezember 2019

#32
HARY

hary

Moin
Danke fuer die Rueckmeldung. Den naechsten Code bekommst du selber hin. ;-))
gruss hary

hary, 16. Dezember 2019

#33
USER

User

Suchen und Summe bilden

Fast, leider ist mir doch noch was aufgefallen was es kompiliert für mich macht!
.Range("A29:I" & .Cells(.Rows.Count, "C").End(xlUp).Row).Copy Cells(29, "A")

Hier kopierst du ja aus den DE**** Datei in die von mir.
Leider beginnt die nicht immer in 29 sondern auch schon mal in 18 oder 19.
Könnte man das anpassen in dem man nach der Zeile sucht bei der alle Zellen von A-I gefüllt sind und dann ab der nächsten die Daten kopiert nicht schon die da das nur die Überschrift ist?
Einfügen bleibt bei Zelle 29.

Sorry, das ist mir doch noch etwas zu schwer.

User, 16. Dezember 2019

#34
HARY

hary

Moin
Ungetestet.
Code:

Sub holen_Umwandeln()
'-- holt die Daten aus der(wenn geoeffneten) Mappe "DE****"
Dim wbk As Workbook
Dim lngLetzeZeile As Long, lngLetzeZeile2 As Long, i As Long
Dim offen As Boolean
Application.ScreenUpdating = False '--Bildschirmflackern ausschalten
lngLetzeZeile = Cells(Rows.Count, "C").End(xlUp).Row
'--loescht alte Daten
Range(Cells(29, "A"), Cells(lngLetzeZeile, "P")).Clear '-- A bis P loeschen
'--kopiert Daten und fuegt diese ein, wenn Mappe "DE**" geoeffnet
For Each wbk In Workbooks '--Schleife ueber geoeffnete Mappen
If wbk.Name Like "DE*" Then '--wenn Mappenname beginnt mit DE
With Workbooks(wbk.Name).Worksheets("Sheet1") '--ggf. Blattname anpassen
.Range("C1:C5").Copy Cells(1, "C")
.Range("D1:D5").Copy Cells(1, "D")
For i = 1 To .Cells(.Rows.Count, "C").End(xlUp).Row
'--sucht belegte Zeile
If Application.CountA(.Cells(i, 1).Resize(1, 9)) = 9 Then
lngLetzeZeile2 = i
Exit For
End If
Next
'-----
.Range("A" & lngLetzeZeile2 + 1 & ":I" & .Cells(.Rows.Count, "C").End(xlUp).Row).Copy Cells(29, "A")
Application.CutCopyMode = False
End With
offen = True
Exit For '--Schleife beenden
End If
Next
If Not offen Then '--wenn betr. Mappe nicht offen
MsgBox "passende Mappe nicht offen", vbCritical, "Hinweis"
Exit Sub '--Makro beenden
End If
'--umwandeln Text in Zahl
Range("H29:H" & Cells(Rows.Count, "C").End(xlUp).Row).TextToColumns Destination:=Range("H29"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'--zieht die Formeln runter
Range("J28:N28").AutoFill Destination:=Range("J28:N" & Cells(Rows.Count, "C").End(xlUp).Row), Type:=xlFillDefault
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

gruss hary

hary, 16. Dezember 2019

#35
USER

User

Danke sieht gut aus *Smilie

User, 17. Dezember 2019

#36
USER

User

Hallo hary,

es ist mit noch was aufgefallen, leider finde ich da keine Lösung für.

Sub holen_Umwandeln()

Wenn ich das Makro holen Umwandeln starte und keine Tabelle mit DE geöffnet ist löscht er die Daten von A29 abwärts und zeigt die Fehlermeldung
an. Wenn ich jetzt jetzt noch mal starte ohne das die DE Tabelle geöffnet ist kommt wieder die Fehlermeldung, alles super, leider löscher er mit dann aber die Zelle in 28 und 27 und somit die Formeln und Überschriften könnte man das verhindern.

User, 17. Dezember 2019

#37
HARY

hary

Suchen und Summe bilden

Moin
Tip: Nutze F8 Taste(Einzelschritt). So siehst du was, in welcher Codezeile, gemacht wird. Das entsprechende einfach versetzen.
Code:

Sub holen_Umwandeln()
'-- holt die Daten aus der(wenn geoeffneten) Mappe "DE****"
Dim wbk As Workbook
Dim lngLetzeZeile As Long, lngLetzeZeile2 As Long, i As Long
Dim offen As Boolean
Application.ScreenUpdating = False '--Bildschirmflackern ausschalten
'--Begrenzung der ltz. Zeile nur ab 29
lngLetzeZeile = Application.Max(29, Cells(Rows.Count, "C").End(xlUp).Row)
'--kopiert Daten und fuegt diese ein, wenn Mappe "DE**" geoeffnet
For Each wbk In Workbooks '--Schleife ueber geoeffnete Mappen
If wbk.Name Like "DE*" Then '--wenn Mappenname beginnt mit DE
'--loescht alte Daten
Range(Cells(29, "A"), Cells(lngLetzeZeile, "P")).Clear '-- A bis P loeschen
With Workbooks(wbk.Name).Worksheets("Sheet1") '--ggf. Blattname anpassen
.Range("C1:C5").Copy Cells(1, "C")
.Range("D1:D5").Copy Cells(1, "D")
For i = 1 To .Cells(.Rows.Count, "C").End(xlUp).Row
'--sucht belegte Zeile
If Application.CountA(.Cells(i, 1).Resize(1, 9)) = 9 Then
lngLetzeZeile2 = i
Exit For
End If
Next
'-----
.Range("A" & lngLetzeZeile2 + 1 & ":I" & .Cells(.Rows.Count, "C").End(xlUp).Row).Copy Cells(29, "A")
Application.CutCopyMode = False
End With
offen = True
Exit For '--Schleife beenden
End If
Next
If Not offen Then '--wenn betr. Mappe nicht offen
MsgBox "passende Mappe nicht offen", vbCritical, "Hinweis"
Exit Sub '--Makro beenden
End If
'--umwandeln Text in Zahl
Range("H29:H" & Cells(Rows.Count, "C").End(xlUp).Row).TextToColumns Destination:=Range("H29"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'--zieht die Formeln runter
Range("J28:N28").AutoFill Destination:=Range("J28:N" & Cells(Rows.Count, "C").End(xlUp).Row), Type:=xlFillDefault
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

gruss hary

hary, 17. Dezember 2019

#38
USER

User

Hallo hary,

es funktioniert jetzt alles super.
Ich danke dir noch mal für deine tolle Unterstützung!
Ich würde dir ja gern ein Bier ausgeben.

User, 18. Dezember 2019

#39
USER

User

Hallo hary,
jetzt habe ich mich mal selber versucht. Lieder komme ich mit der Sprache nicht so richtig zurecht.
Sub speichern()
'
' speichern Makro

ActiveWorkbook.SaveAs Range("B2").Value & Range("C4").Value & ".xls"
End Sub
Hier wird die Datei jetzt auch abgespeichert leider nicht so wie ich es gern hätte. Es soll ohne Makros gespeichert werden, sind aber noch drin, wenn möglich auch als gesperrte Mappe, sodass der, der sie öffnet nicht daran ändern kann, aber die Zellen anwählen kann.
Mit welchem Befehl setzt ich vor die Zelle B2 das aktuelle Datum? Und wie bekommen ich zwischen die Zelle B2 und C4 einen _ Unterstrich?
Kann man das auch so ändern das er vor dem Speichern nach den Speicherort fragt?

Ist doch alles nicht so einfach 

User, 18. Dezember 2019

#40
HARY

hary

Moin
Auf die schnelle,muss weg.
Code:

Sub speichern()
Dim strVerzeichnis As String, strDateiname As String
Dim wks As Worksheet
For Each wks In woksheets
wks.protekt "Passwort" '--aendern
Next
strDateiname = Application.GetSaveAsFilename(InitialFileName:=Date & Range("B2") & "_" & Range("C4") & ".xls", _
FileFilter:="Microsoft Excel-Arbeitsmappe (*.xls), *.xls")
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs strDateiname
Application.DisplayAlerts = True
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

gruss hary

hary, 18. Dezember 2019

#41
USER

User

Hallo hary,

vielen Dank! Es funktioniert zum Teil.

Das mit dem Passwort musste ich löschen, dann ist nicht passiert.
For Each wks In woksheets
wks.protekt "Passwort" '--aendern

Mit dem Speichern klappt super, leider kommt der Felder beim Öffnen noch das es das falsche Dateiformat ist ob man die Markos wieder öffnen will. Das müsste noch weg.
Wäre es möglich das Datum mit Jahr. Monat. Tag anzugeben?

strDateiname = Application.GetSaveAsFilename(InitialFileName:=Date & Range("B2") & "_" & Range("C4") & ".xls", _
FileFilter:="Microsoft Excel-Arbeitsmappe (*.xls), *.xls")
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs strDateiname
Application.DisplayAlerts = True

Und noch mal Dankeschön.

User, 18. Dezember 2019

#42
HARY

hary

Suchen und Summe bilden

Moin
Da schrieb ich zu schnell.
Schreibfehler haetten dir aber auffalllen koennen. Beim Schutz.
Jetzt auch getestet.
Edit: mit FileFormat:=xlExcel8 sollte der Oeffnungsfehler nicht mehr kommen.
Code:

Sub speichern()
Dim strDateiname As String
Dim wks As Worksheet
Dim Datum As Date
For Each wks In Worksheets
wks.Protect "Passwort" '--aendern
Next
Datum = Application.InputBox("Bitte Speicherdatum eingeben/ändern", "Datumseingabe", Format(Date, "DD.MM.YY"))
If IsDate(Datum) And CLng(Datum) > 1 Then
strDateiname = Application.GetSaveAsFilename(InitialFileName:=Datum & Range("B2") & "_" & Range("C4") & ".xls", _
FileFilter:="Microsoft Excel-Arbeitsmappe (*.xlsx), *.xlsx")
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs strDateiname, FileFormat:=xlExcel8, CreateBackup:=False
Application.DisplayAlerts = True
End If
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

gruss hary

hary, 19. Dezember 2019

#43
USER

User

Hallo hary,
Vielen Dank, bestimmt hätte man das sehen können aber ich? *wink.gif*
Leider ist das nicht das was ich mir gedacht habe.
Wenn ich auf abbrechen beim Speichern gehen, macht es eine .xls Datei daraus und nennt sie Falsch.
Habe das mit dem Eingeben des Datums gelöscht. Wenn sollte es automatisch das aktuelle Datum wählen und nicht so schreiben 19.12.2019 sondern 2019.12.19 wäre aber auch so ok.
Ich habe es mit jetzt so angepasst und nutze es nur zum Abspeichern der Datei mit Makro!
Leider funktioniert das beim Öffnen nicht und ich bekomme die Fehlermeldung:
Die Datei kann nicht geöffnet werden, da die Dateierweiterung ungültig ist?
Sub speichern()
Dim strDateiname As String
Dim wks As Worksheet
Dim Datum As Date
strDateiname = Application.GetSaveAsFilename(InitialFileName:=Date & Range("B2") & "_" & Range("C4") & ".xlsm", _
FileFilter:="Microsoft Excel-Arbeitsmappe (*.xlsm), *.xlsm")
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs strDateiname, FileFormat:=xlExcel8, CreateBackup:=False
Application.DisplayAlerts = True

End Sub
Was müsste ich ändern, damit es funktioniert und dann die Makros auch noch gültig sind.

Jetzt zu dem eigentlichen Problem, ich wollte das Speichern nutzen um einer weiteren Person die Möglichkeit zu geben die Daten zu sichten und sie auch zu markieren und zu kopieren aber nicht zu ändern.
Leider ist die Datei mit den Makros nach den Speichern geschlossen und es soll ja die ohne Makros geschlossen werden, damit ich mit der mit noch weiterarbeiten kann.
Könnte man hier auch eine Funktion ähnlich der mit dem speichern über drucken in eine Datei machen? Wenn möglich eine Excel oder zur not auch eine PDF, ein PDF Drucker ist ja vorhanden.

Sorry für die viele Arbeit habe echt ein schlechtes Gewissen, aber die Vorstellung das es funktioniert, überwiegt.

ich kann nicht oft genug Danke sagen *Smilie

User, 19. Dezember 2019

#44
HARY

hary

Moin
So?
Code:

Sub speichern()
Dim strDateiname As String
Dim wks As Worksheet
For Each wks In Worksheets
wks.Protect "Passwort" '--aendern
Next
strDateiname = Application.GetSaveAsFilename(InitialFileName:=Format(Date, "YYYY.MM.DD") & Range("B2") & "_" & Range("C4") & ".xls", _
FileFilter:="Microsoft Excel-Arbeitsmappe (*.xlsx), *.xlsx")
If strDateiname = "Falsch" Then Exit Sub '--wenn abrechen: Makro beenden
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs strDateiname, FileFormat:=xlExcel8, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wenn es nur ein Blatt ist geht es auch mit Copy. Es wird automatisch eine neue Mappe erstellt.
Code:

Sub EinBlatt()
Worksheets("Tabelle1").Copy
Worksheets("Tabelle1").Protect "Passwort"
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wenn du die Mappe als PDF erstellen moechtest. Zeichne es mal mit dem Makrorecorder auf.
edit:
Code:

Sub als_PDF()
Dim strDateiname As String, VerzeichnisAuswaehlen As String
Dim objFiledialog As FileDialog
Set objFiledialog = _
Application.FileDialog(msoFileDialogFolderPicker)
With objFiledialog
.AllowMultiSelect = False
If .Show = True Then
VerzeichnisAuswaehlen = .SelectedItems(1) & ""
End If
End With
strDateiname = Format(Date, "YYYY.MM.DD") & Range("B2") & "_" & Range("C4")
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
VerzeichnisAuswaehlen & strDateiname & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

gruss hary

hary, 19. Dezember 2019

#45

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

Seite 3 von 5

Thema:

Suchen und Summe bilden

Die Seite wird geladen...

Suchen und Summe bilden - Similar Threads - Summe bilden
VBA Summe bilden
in Microsoft Excel Hilfe
VBA Summe bilden: Hallo zusammen, in meiner per VBA generierten Tabelle mit unterschiedlicher Anzahl Zeilen möchte ich in Spalte D die Summe bilden, als von D1 bis Dx. Meine Formel bei 12 Zeilen:...
Excel Summe bilden wenn bestimmtes Wort und Zahl in eine Zelle vorhanden
in Microsoft Excel Hilfe
Excel Summe bilden wenn bestimmtes Wort und Zahl in eine Zelle vorhanden: Hallo liebe Gemeinde, ich habe ein Problem. Ich möchte eine Summe bilden, wenn ein bestimmtes Wort in der Zelle vorhanden ist (die Zahl für die Summe ist ebenfalls in dieser Zelle): jede Zeile...
Summe bilden, wenn eine Zahl gleich sit
in Microsoft Excel Hilfe
Summe bilden, wenn eine Zahl gleich sit: Ich würde gerne eine Summe für Nicken, Zustimmung und Kopfschütteln für die gleichen Versuchspersonennummern bilden und hätte dann gerne eine einzelne Nummer für die Versuchsperson und nicht mehr...
Excel-Summe nur bilden, solange sich Wert nicht ändert?
in Microsoft Excel Hilfe
Excel-Summe nur bilden, solange sich Wert nicht ändert?: Hallo, liebes Forum, ich schildere folgendes Problem: Es liegt ein Excel-Arbeitsblatt vor, in dem Aufgaben einer kommenden Prüfung aufgelistet sind. In Spalte A steht die laufende Nummer der...
Dynamische, auf Basis von Bedingungen, Summen bilden
in Microsoft Excel Hilfe
Dynamische, auf Basis von Bedingungen, Summen bilden: allo zusammen, ich habe ein "kleineres Problemchen". Und zwar würde ich gerne, abhängig davon, Ob in Spalte A das Wort "User Story" steht, eine Summe über die Wert Spalte I bilden, aber nur über...
Mit mehreren Bedingungen dann eine Summe bilden
in Microsoft Excel Hilfe
Mit mehreren Bedingungen dann eine Summe bilden: Hallo, ich habe mal wieder ein kleines Problem, bekomme das einfach nicht hin. Ich möchte mit mehreren Bedingungen aus verschiedenen Zellen eine Summe erzeugen. Habe ein Beispiel mal...
Automatisch Summe bilden abhängig vom Wochentag
in Microsoft Excel Hilfe
Automatisch Summe bilden abhängig vom Wochentag: Hallo, könnt ihr mir bitte helfen? Ich bekomme es nicht hin, das Excel automatisch jeden Sonntag, die Summe der abgelaufenen Woche in Spalte M bildet (inkl. des Sonntags). Super wäre es, wenn...

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