Mehrere Tabellentexte auf einem Tabellenblatt zusammenfassen?

Hallo gutefrage Team,

ich müsste einen VBA-Code abwandeln der so noch nicht passt/funktioniert.

Ich muss aus 12 Tabellen Texte in die 13 Tabelle einfügen ohne Leerzeilen.

Tabelle 1 Texte von A45:47

Tabelle 2 Texte von A35:37; 68:80; 105:117; 141:155; 178:196

Tabelle 3 - 7 Texte von A40:45; 85:90; 130:135; 175:180

Tabelle 8 A42:44

Tabelle 9 A44:48

Tabelle 10 A37:40

Tabelle 11 A27:48

Tabelle 12 A27:31

Die Zusammenfassung sollte untereinander in Tabelle 13 ab A95 eingefügt werden und die Zeilen in denen kein Text ist sollten nicht kopiert werden.

Sub Tabellentext_zusammenfassen()

Dim i As Integer

Dim Zusammenfassen As Worksheet

Set Zusammenfassen = Worksheets("Zusammenfassung")

For i = 1 To Workshheet.Count

Set BereichZielTab = Worksheets(i).UsedRange

Set LetzteZeileZusammenfassung = Worksheets(1).Cells(Rows.Count, "A45:47").End(xlUp)

BereichZielTab.Copy Destination:=LetzteZeileZusammenfassung

Next i

End Sub

Danke Vorab

27.02.2023, 18:46

Hallo DanKirpan,

kannst du mir bei der Anpassung nochmal helfen?

!! Info alle Blätter haben noch einen Blattschutz!!

Tabelle 1 = Deckblatt

Tabelle 2 = VDE und Funktionsprüfung

Tabelle 3 = Stromdurchflutung

Tabelle 4 = Jochmagnetisierung

Tabelle 5 = Spulenmagnetisierung

Tabelle 6 = Hilfsdurchflutung

Tabelle 7 = Induktionsdurchflutung

Tabelle 8 = ASTM

Tabelle 9 = Entmagn., Feldlagen und UV-Beleuchtung

Tabelle 10 = EM6

Tabelle 11 = Prüfmittel

Tabelle 12 = Bewertung

Tabelle 13 Zertifikat (Ziel Tabelle A95)

Danke schon mal im Voraus.

1 Antwort

Vom Fragesteller als hilfreich ausgezeichnet

DanKirpan

Von gutefrage auf Grund seines Wissens auf einem Fachgebiet ausgezeichneter Nutzer

Microsoft Excel

27.02.2023, 10:20

Hallo,

dazu kannst du dies verwenden:

Sub Tabellentext_zusammenfassen()
Dim i As Long, lZei As Long
Dim CopBer As Range, Zelle As Range
Dim AusBer As String, AusBlatt As String


    For i = 1 To 12
'Bereiche und Blatt festlegen das ausgelesen wird
        AusBlatt = "Tabelle" & i
        Select Case i
            
        Case 1
            AusBer = "A45:A47"
        Case 2
            AusBer = "A35:A37, A68:A80, A105:A117, A141:A155, A178:A196"
        Case 3 'gilt für 3-7 da die Fälle 4-7 nicht anders festgelegt sind
            AusBer = "A40:A45, A85:A90, A130:A135, A175:A180"
        Case 8
            AusBer = "A42:A44"
        Case 9
            AusBer = "A44:A48"
        Case 10
            AusBer = "A37:A40"
        Case 11
            AusBer = "A27:A48"
        Case 12
            AusBer = "A27:A31"
        End Select
        
        Set CopBer = ActiveWorkbook.Sheets(AusBlatt).Range(AusBer)
        
'Inhalte kopieren unter Ausschluss von Leerwerten
        With ActiveWorkbook.Sheets("Tabelle13")
            For Each Zelle In CopBer
                If Zelle.Value <> "" Then
                    lZei = Application.WorksheetFunction.Max(95, .Range("A" & .Rows.Count).End(xlUp).Row + 1)
                    .Range("A" & lZei) = Zelle.Value
                End If
            Next Zelle
        End With
    Next i
End Sub

Es wird jedes Blatt durchgegangen, darauf der gewünschte Bereich festgelegt und Zelle für Zelle aufgelistet. Sollten deine Blätter nicht tatsächlich Tabelle1 , Tabelle2 etc. heißen müsstest du den Blattnamen noch mit in den Fällen anpassen.

86hesse

Fragesteller

27.02.2023, 17:03

Danke DanKirpan,

werde es gleich Versuchen.

Mfg

86hesse

Fragesteller

27.02.2023, 17:53

Hallo DanKirpan,

kannst du mir bei der Anpassung nochmal helfen?

!! Info alle Blätter haben noch einen Blattschutz!!

Tabelle 1 = Deckblatt

Tabelle 2 = VDE und Funktionsprüfung

Tabelle 3 = Stromdurchflutung

Tabelle 4 = Jochmagnetisierung

Tabelle 5 = Spulenmagnetisierung

Tabelle 6 = Hilfsdurchflutung

Tabelle 7 = Induktionsdurchflutung

Tabelle 8 = ASTM

Tabelle 9 = Entmagn., Feldlagen und UV-Beleuchtung

Tabelle 10 = EM6

Tabelle 11 = Prüfmittel

Tabelle 12 = Bewertung

Tabelle 13 Zertifikat (Ziel Tabelle A95)

Danke schon mal im Voraus.

DanKirpan

28.02.2023, 12:32

@86hesse

Hallo,

hatte erst jetzt wieder etwas Zeit. Wenn das Zertifkat-blatt ebenfalls einen Schutz hat, müsstest du diesen temporär aufheben, auf den anderen Blättern hat er für das Makro keine Auswirkung.

Sonst genügt es wie gesagt den Blattnamen mit in der Case-Anweisung festzulegen. Tabelle9 "Entmagn., Feldlagen und UV-Beleuchtung" ist bei mir allerdings ein unmöglicher Blattname da er länger als 31 Zeichen ist, da müsstest du nochmal prüfen ob Excel den geplanten Namen bei dir nicht automatisch gekürzt hat und entsprechend Case 9 anpassen.

Sub Tabellentext_zusammenfassen()
Dim i As Long, lZei As Long
Dim CopBer As Range, Zelle As Range
Dim AusBer As String, AusBlatt As String




    For i = 1 To 12
'Bereiche und Blatt festlegen das ausgelesen wird
        AusBlatt = "Tabelle" & i
        Select Case i
            
        Case 1
            AusBer = "A45:A47"
            AusBlatt = "Deckblatt"
        Case 2
            AusBer = "A35:A37, A68:A80, A105:A117, A141:A155, A178:A196"
            AusBlatt = "VDE und Funktionsprüfung"
        Case 3
            AusBer = "A40:A45, A85:A90, A130:A135, A175:A180" 'gilt für 3-7 da die Fälle 4-7 nicht anders festgelegt sind
            AusBlatt = "Stromdurchflutung"
        Case 4
            AusBlatt = "Jochmagnetisierung"
        Case 5
            AusBlatt = "Spulenmagnetisierung"
        Case 6
            AusBlatt = "Hilfsdurchflutung"
        Case 7
            AusBlatt = "Induktionsdurchflutung"
        Case 8
            AusBer = "A42:A44"
            AusBlatt = "ASTM"
        Case 9
            AusBer = "A44:A48"
            AusBlatt = "Tabelle9"
            'AusBlatt = "Entmagn., Feldlagen und UV-Beleuchtung" 'Name länger als 31 Zeichen
        Case 10
            AusBer = "A37:A40"
            AusBlatt = "EM6"
        Case 11
            AusBer = "A27:A48"
            AusBlatt = "Prüfmittel"
        Case 12
            AusBer = "A27:A31"
            AusBlatt = "Bewertung"
        End Select
        
        Set CopBer = ActiveWorkbook.Sheets(AusBlatt).Range(AusBer)
        
'Inhalte kopieren unter Ausschluss von Leerwerten
        With ActiveWorkbook.Sheets("Zertifikat") 'Tabelle13 = Zertifikat
            For Each Zelle In CopBer
                If Zelle.Value <> "" Then
                    lZei = Application.WorksheetFunction.Max(95, .Range("A" & .Rows.Count).End(xlUp).Row + 1)
                    .Range("A" & lZei) = Zelle.Value
                End If
            Next Zelle
        End With
    Next i
End Sub

86hesse

Fragesteller

28.02.2023, 15:00

@DanKirpan

Danke ich Versuche es später, melde mich aber nochmal bei dir.

Vielen Dank

86hesse

Fragesteller

28.02.2023, 16:39

@DanKirpan Hallo DanKirpanEs kommt nur noch die MeldungSubscript außerhalb des Bereichs (Fehler 9 )

Fehler bei:

Set CopBer = ActiveWorkbook.Sheets(AusBlatt).Range(AusBer)

Sub Tabellentext_zusammenfassen()

Dim i As Long, lZei As Long

Dim CopBer As Range, Zelle As Range

Dim AusBer As String, AusBlatt As String

For i = 1 To 12

'Bereiche und Blatt festlegen das ausgelesen wird

AusBlatt = "Tabelle" & i

Select Case i

Case 1

AusBer = "A45:A47"

AusBlatt = "Deckblatt"

Case 2

AusBer = "A35:A37, A68:A80, A105:A117, A141:A155, A178:A196"

AusBlatt = "VDE und Funktionsprüfung"

Case 3

AusBer = "A40:A45, A85:A90, A130:A135, A175:A180" 'gilt für 3-7 da die Fälle 4-7 nicht anders festgelegt sind

AusBlatt = "Stromdurchflutung"

Case 4

AusBlatt = "Jochmagnetisierung"

Case 5

AusBlatt = "Spulenmagnetisierung"

Case 6

AusBlatt = "Hilfsdurchflutung"

Case 7

AusBlatt = "Induktionsdurchflutung"

Case 8

AusBer = "A42:A44"

AusBlatt = "ASTM"

Case 9

AusBer = "A44:A48"

AusBlatt = "Entmag.,Feldlagen und UV-Beleuc"

'AusBlatt = "Entmagn., Feldlagen und UV-Beleuchtung" 'Name länger als 31 Zeichen

Case 10

AusBer = "A37:A40"

AusBlatt = "EM6"

Case 11

AusBer = "A27:A48"

AusBlatt = "Prüfmittel"

Case 12

AusBer = "A27:A31"

AusBlatt = "Bewertung"

End Select

Set CopBer = ActiveWorkbook.Sheets(AusBlatt).Range(AusBer)

'Inhalte kopieren unter Ausschluss von Leerwerten

With ActiveWorkbook.Sheets("Zertifikat") 'Tabelle18 = Zertifikat

For Each Zelle In CopBer

If Zelle.Value <> "" Then

lZei = Application.WorksheetFunction.Max(95, .Range("A" & .Rows.Count).End(xlUp).Row + 1)

.Range("A" & lZei) = Zelle.Value

End If

Next Zelle

End With

Next i

End Sub

DanKirpan

28.02.2023, 16:53

@86hesse

Fehler 9 bedeutet das es auf etwas zugreifen versucht, das nicht existiert. Haben sich beim benennen der Tabellen evtl. Leerzeichen verdoppelt oder am Wortende eingeschlichen?

86hesse

Fragesteller

28.02.2023, 16:55

@86hesse

Sorry mein Fehler dein Code funktioniert.

Habe

nur noch eins zum Thema

ich habe noch etwas in der Tabelle18 = Zertifikat bei A99:100 und 103:104 stehen

die zwei Zeilen sollten nach unten geschoben werden und als letztes stehen.

Sorry

für die Umstände

DanKirpan

28.02.2023, 17:13

@86hesse

Ah okay und kein Problem wegen den Umständen^^

Das ist dasselbe Blatt wie das auf das die Einträge geschrieben werden oder? Dann müsste man sie entweder zwischenspeichern oder die Eintragszeile anders festlegen.

(Nicht auf senden geklickt hier der überarbeitete Absatz des Codes)

'Inhalte kopieren unter Ausschluss von Leerwerten
        With ActiveWorkbook.Sheets("Zertifikat") 'Tabelle13 = Zertifikat
            For Each zelle In CopBer
                If zelle.Value <> "" Then
                    lZei = Application.WorksheetFunction.Max(95, lZei + 1)
                    .Range("A" & lZei).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .Range("A" & lZei) = zelle.Value
                End If
            Next zelle
        End With
    Next i

Hallo Zusammen,

Ich hab ein Problem. Ich würde gern durch das schreiben einer 1 hinter meiner Materialsammlung per Knopfdruck alle gewählten Zeilen in eine Zusammengestellte Tabelle einfügen.

Die Materialsammlung bei der ich auswähle ist in Tabelle zwei und wird dann per Knopfdruck abgefragt. Die markierten sollen dann in Tabelle 1 in eine Tabelle eingefügt werden.

Da ich aber mit Variablen Arbeite ist das schwieriger als gedacht

Hier mein code zum verdeutlichen

Private Sub CommandButton1_Click()

Dim strBereich As Range Dim x As Integer

For x = 3 To 60 If Worksheets(2).Cells(x, 10) = "1" Then

Worksheets(1).Range(Cells(x, 2), Cells(x, 9))=Worksheets(2).Range(Cells(x, 1), Cells(x, 8))

End If Next x

End Sub

funktioniert leider aber nicht.

Bitte im Hilfe

...zur Frage

Excel VBA - Darstellung waagerecht-vertikal beim kopieren ändern?

Hallo,

ich habe in einer fertigen Tabelle etwas geändert, um die Eingabe der Daten zu erleichtern. Statt die Daten in der Spalte zu erfassen, werden die Daten jetzt in einer Zeile eingegeben.

Also statt vorher in B10, B11, B12... jetzt in B10, C10, D10...

Die Daten werden mit Hilfe eine Makros in eine andere Tabelle transferiert und waagerecht eingefügt.

Da ich aber die Eingabeart verändert habe, werden die Daten jetzt untereinander in die Tabelle eingefügt.

Ich weiß, dass das mit "Application.Transpose" zu tun hat.

Nun weiss ich aber nicht wie ich die Zeile umbenennen muss, damit die waagerechte Darstellung übernommen wird.

Wie ändere ich die Zeile, damit die angesprochenen Werte waagerecht in die Zeile kopiert werden?

Hier der komplette Code:

Sub transfer_werte()
    Dim rngKunde    As Excel.Range
    Dim rngReklam   As Excel.Range
    Dim rngArtikel   As Excel.Range

     Set rngKunde = Worksheets("Eingaben").Range("C5:C10")
    Set rngReklam = Worksheets("Eingaben").Range("D5:D9")
    Set rngArtikel = Worksheets("Eingaben").Range("C14:L14")
   
        With Worksheets("Liste")
          With .Cells(.Rows.Count, 2).End(xlUp)
               .Offset(1, 0).Resize(rngKunde.Columns.Count, rngKunde.Rows.Count).Value = Application.Transpose(rngKunde.Value)
        End With
    End With
   
    With Worksheets("Liste")
        With .Cells(.Rows.Count, 8).End(xlUp)
             .Offset(1, 0).Resize(rngReklam.Columns.Count, rngReklam.Rows.Count).Value = Application.Transpose(rngReklam.Value)
        End With
    End With
  
   With Worksheets("Liste")
        With .Cells(.Rows.Count, 14).End(xlUp)
             .Offset(1, 0).Resize(rngArtikel.Columns.Count, rngArtikel.Rows.Count).Value = Application.Transpose(rngArtikel.Value)
        End With
    End With
      
End Sub

...zur Frage

Excel Macro: Formel dynamisch machen, um Zellenbereich auszuwählen?

Liebe Community,

ich habe folgendes Macro in meiner Excel Tabelle. Es funktioniert auch wunderbar, bis auf die Tatsache, dass dort der Tabellenbereich aus der fremden Excel-Datei definiert ist.

Leider sind es nicht immer 239 Zeilen. Mal mehr und mal weniger. Dass es bei A7 anfängt, das stimmt schon. Wie müsste ich die Formel ändern, damit Excel sich automatisch anpasst?

Vielen lieben Dank im Voraus!

Es handelt sich um diese Zeile wbQuelle.Worksheets(1).Range("A7:I239").Copy

Sub Quelle()

Dim sPfad As String
Dim wbQuelle As Workbook
Dim zelle As Range

sPfad = "C:\Users\Beispiel\Desktop\Irgendeine Datei\Daten\Daten.xlsx"

If Dir(sPfad) <> "" Then

Set wbQuelle = Workbooks.Open(sPfad)

wbQuelle.Worksheets(1).Range("A7:I239").Copy ThisWorkbook.Worksheets(3).Range("B2")

wbQuelle.Close savechanges:=False

End If

End Sub

...zur Frage

Tabellen mit vba nebeneinander anstatt untereinander anordnen?

Hallo,

ich habe bereits meine Excel-Arbeitsmappe bestehend aus 250 Seiten mit jeweils 2Spalten und 250 Zeilen via vba zusammengeführt.

Allerdings wird dabei alles untereinander dargestellt und nicht nebeneinander. Kann man es so machen, dass sobald ein Worksheet abgearbeitet wurde und angezeigt wird, das nächste daneben in der Spalte beginnen lässt und immer so weiter.

Gibt es Möglichkeiten dort eine Art „Cut“ zu machen?

Sub Konsolidieren()
Dim Wks As Worksheet
Dim Bereich As Range
Dim strLC As String
Dim i As Integer
Set Wks = Worksheets.Add
Wks.Name = "Gesamt"
For i = 2 To Worksheets.Count
 With Worksheets(i).UsedRange
 strLC = .Cells(.Rows.Count, .Columns.Count).Address
 Set Bereich = .Range("A1:" & strLC)
 Bereich.Copy Destination:= _
 Wks.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
 End With
Next i
End Sub

...zur Frage

Zweidimensionales Array einlesen?

Hallo Ich möchte eine Tabelle mit 2 Spalten per Array in Excel VBA per Array einlesen lassen. Mein Programmcode sieht bisher so aus:

Sub aaaaa()

Dim bbbb(1 To 8, 1 To 2)

Dim i As Integer

For i = 1 To 8

bbbb(i, 1) = Worksheets("cccc").Range("i1").Value

bbbb(i, 2) = Worksheets("cccc").Range("i2").Value

Next i

End Sub

Leider funktioniert das Ganze nicht. Hat jemand eine Idee woran es liegen könnte?

Danke!

...zur Frage

IF Funktion in excel auf mehrere Zellen anwenden?

Hallo,

Ich möchte wenn in einer Zelle etwas reingeschrieben wird das die darauffolgenden Felder zu Pflichtfelder werden. Dazu nutze ich aktuell folgende Formel.

Private Sub Workbook_BeforePrint(Cancel As Boolean)

Dim zeile As Long, OK As Boolean

OK = True

For zeile = 1 To Tabelle1.Cells.SpecialCells(xlCellTypeLastCell).Row

If Worksheets("Tabelle1").Cells(4, 2).Value <> "" Then

If Worksheets("Tabelle1").Cells(4, 3).Value = "" Then OK = False 'Spalte C

If Worksheets("Tabelle1").Cells(4, 4).Value = "" Then OK = False 'Spalte D

If Worksheets("Tabelle1").Cells(4, 5).Value = "" Then OK = False 'Spalte E

If Worksheets("Tabelle1").Cells(4, 6).Value = "" Then OK = False 'Spalte F

If Worksheets("Tabelle1").Cells(4, 8).Value = "" Then OK = False 'Spalte H

If Worksheets("Tabelle1").Cells(4, 9).Value = "" Then OK = False 'Spalte I

End If

If Not OK Then

MsgBox "Drucken nicht möglich - nicht alle Pflichtfelder ausgefüllt"

Cancel = True

End If

End Sub

Nun möchte ich das die obige Formel von B4- B25 durchgeführt wird. Also das wenn in in B8 z.B. etwas reingeschrieben wird das dann die Zellen in B8 geprüft werden das dort in den anderen Feldern auch was reingeschrieben worden ist.
Wie würde ich das ganze hinbekommen?

Danke im Voraus

...zur Frage

Maximale Pfadlänge in Windows und VBA umgehen?

Hallo,

ich benutze folgenden Code in Excel VBA um mir Dateipfad und Dateiname eines Ordners und allen darin enthaltenen Unterordnern aufzulisten.
(Ihr könnt es testen, den Code einfach in ein Modul kopieren, "MainList" ausführen und einen Ordner eurer Wahl auswählen)

Ich habe jetzt das Problem, dass dieser Code alle Dateien überspringt, deren Pfadlänge über 255 Zeichen lang ist. Einige Dateien überschreiten nämlich die 255 Zeichen mit dem angehängten Dateinamen.
Sie liegen aber dennoch ab. Nur liest VBA diese nicht aus. Kann man da was dran machen?

Sub MainList()
'Updateby Extendoffice
Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
If Folder.Show <> -1 Then Exit Sub
xDir = Folder.SelectedItems(1)
Call ListFilesInFolder(xDir, True)
End Sub

Sub ListFilesInFolder(ByVal xFolderName As String, ByVal xIsSubfolders As Boolean)
Dim xFileSystemObject As Object
Dim xFolder As Object
Dim xSubFolder As Object
Dim xFile As Object
Dim rowIndex As Long
Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFileSystemObject.GetFolder(xFolderName)
rowIndex = Application.ActiveSheet.Range("A65536").End(xlUp).Row + 1
For Each xFile In xFolder.Files
  Application.ActiveSheet.Cells(rowIndex, 1).Formula = xFile.Path
  Application.ActiveSheet.Cells(rowIndex, 2).Formula = xFile.Name
  rowIndex = rowIndex + 1
Next xFile
If xIsSubfolders Then
  For Each xSubFolder In xFolder.SubFolders
    ListFilesInFolder xSubFolder.Path, True
  Next xSubFolder
End If
Set xFile = Nothing
Set xFolder = Nothing
Set xFileSystemObject = Nothing
End Sub

Function GetFileOwner(ByVal xPath As String, ByVal xName As String)
Dim xFolder As Object
Dim xFolderItem As Object
Dim xShell As Object
xName = StrConv(xName, vbUnicode)
xPath = StrConv(xPath, vbUnicode)
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.Namespace(StrConv(xPath, vbFromUnicode))
If Not xFolder Is Nothing Then
  Set xFolderItem = xFolder.ParseName(StrConv(xName, vbFromUnicode))
End If
If Not xFolderItem Is Nothing Then
  GetFileOwner = xFolder.GetDetailsOf(xFolderItem, 8)
Else
  GetFileOwner = ""
End If
Set xShell = Nothing
Set xFolder = Nothing
Set xFolderItem = Nothing
End Function

...zur Frage

Excel Makro, PDF versenden, Anhang klappt nicht?

Hallo, ich würde gerne eine Rechnung mit einem Makro erstellen. Soweit klappt das auch und die Mail öffnet sich auch, aber diese wird nicht als Anhang hinzugefügt. Ich komme leider nicht drauf. Ich denke, es liegt daran, dass er die Datei nicht findet, aber ich wüsste keinen Lösungsansatz. Hier der Code:

Dim Result As VbMsgBoxResult

Sub RechnungsnrUndDrucken()

Sheets("Rechnung_Video").Select

[D15] = [D15] + 1 'Rechnungsnummer 1 hochzählen

Dim sCC As String

Dim sName As String

Dim sText As String

Dim sObject As String

Dim sCompany As String

Dim sRefNr As String

Dim sTempFileName As String

If (CStr(ThisWorkbook.ActiveSheet.Name) = "Rechnung") Then

Result = MsgBox("Rechnung fertig?", vbApplicationModal Or vbQuestion Or vbYesNo)

If Result = vbNo Then Exit Sub

End If

Const DateiPfad = "C:\Temp\"

Dim DateiName As String

DateiName = DateiPfad & Range("C15") & Range("D15") & ".pdf"

Range("A1:F54").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

DateiName, Quality:=xlQualityStandard, _

IncludeDocProperties:=True, _

IgnorePrintAreas:=False, _

OpenAfterPublish:=False

Dim Nachricht As Object, OutApp As Object

Dim AWS As String

Set OutApp = CreateObject("Outlook.Application")

AWS = strFileName

'InitializeOutlook = True

Set Nachricht = OutApp.CreateItem(0)

With Nachricht

.Subject = "" & Range("A1") & "_" & Range("C15") & Range("D15")

.GetInspector.display

'.Attachments.Add ("C:\Temp\" & Range("C15") & Range("D15") & ".pdf")

End With

Set OutApp = Nothing

Set Nachricht = Nothing

End Sub

...zur Frage

Excel: Wie gestalte ich dieses Makro schneller und effektiver und sorge dafür, dass es bei Neustart nur neue Werte erkennt?

Wie kann ich dieses Makro schneller und effektiver machen und wie bekomme ich es hin, dass es beim Neustart nicht schon wieder die Werte erkennt, die schon einmal dran waren? Sodass die 50 nach dem ersten Mal Abspielen des Sounds ignoriert wird.

Code:

Sub PlaySound()
  Dim ws As Worksheet
  Dim rng As Range
  Dim cell As Range
  Dim goals As Long
  Dim soundFile As String
  Dim thresholds As Variant
  Dim i As Integer
  Set ws = ThisWorkbook.Worksheets("Spielplan")
  Set rng = ws.Range("O1:O" & ws.Cells(ws.Rows.Count, "O").End(xlUp).row)
  soundFile = "Sound_pfad.mp3"
  'Array of threshold values
  thresholds = Array(50, 100, 150, 200, 250, 300, 350, 400, 450, 500,550,600,650,700,750,800,850,900,950,1000)
  Do While True 'Endlosschleife hinzugefügt
    For Each cell In rng
      If IsNumeric(cell.Value) Then
        goals = goals + cell.Value
        'Check if goals is equal to any of the threshold values
        For i = LBound(thresholds) To UBound(thresholds)
          If goals = thresholds(i) Then
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            ActiveSheet.OLEObjects.Add(Filename:=soundFile, Link:=False, DisplayAsIcon:=False).Select
            Selection.Verb Verb:=xlPrimary
            Selection.Delete
            Application.ScreenUpdating = True
            Application.EnableEvents = True
          End If
        Next i
      End If
    Next cell
    'Verzögerung hinzugefügt, um die CPU-Auslastung zu reduzieren
    Application.Wait (Now + TimeValue("0:05:00"))
  Loop
End Sub

...zur Frage

VBA: Automatisch mehrere Tabellenblätter löschen?

Moin, ich möchte gerne mehrere Tabellenblätter löschen (Excel -> VBA). Das Problem dabei: Die Nummer des ersten und letzten zu löschenden Blattes soll abgefragt werden. Habe jetzt schon die eine oder andere Zeile "zusammengebastelt", allerdings läuft das Sub noch nicht so ganz rund. Kann mir da jemand weiterhelfen?? Bin mit VBA leider nicht so vertraut....

Sub Aufgabe 17()

Dim intWert1 As Integer
Dim intWert2 As Integer
Dim intWert3 As Integer

intWert1 = InputBox("Nummer des ersten zu löschenden Blattes?", "Tabellenblätter löschen", 0)
intWert2 = InputBox("Nummer des letzten zu löschenden Blattes?", "Tabellenblätter löschen", 0)

Application.DisplayAlerts = False

For intWert3 = intWert1 To intWert2
    intWert3 = "Tabelle" + intWert1
    Worksheets(intWert3).Delete
Next intWert3

Application.DisplayAlerts = True

End Sub

...zur Frage

Wie berechne ich 30 min Mittelwerte in VBA?

Hallo Zusammen ,

ich bin leider wirklich nicht fit was das Thema Makro schreiben angeht deshalb habe ich folgendes Problem:

Ich habe mehrer Spalten mit etwa 1000 Zeilen voller Daten. Es handelt sich dabei um Minutenwerte. Diese würde ich gerne in 30 min Werte zusammenfassen. Da das händisch ewig dauert bräuchte ich dafür ein Makro welches den Mittelwert bildet und 3 Spalten weiter in der ersten Zeile (wo auch der erste Werte der zur Mittelwertsberechnung rangezogen wird notiert ist). Dann soll der nächste Mittelwert mit den Folgenden 29 Minuten-Werten gebildet werden, 3 Spalten weiter unter dem vorherigen Mittelwert notiert werden.

Folgendes habe ich versucht:

Sub Halbstundenmittelwerte()

Dim i As Integer

Dim z As Integer

Dim x As Integer

Dim MW As Double

For i = 10 To 15010 Step 30

z = i

x = z + 29

Range(Hz).Select

ActiveCell.FormulaR1C1 ="= AVERAGE("Cz:Cx")"

Range(Hi).Value = MW

Next i

End Sub

Danke euch !

...zur Frage

VBA Input-Eingabe in Zelle eintragen?

Guten Abend,

ich möchte gerne den Inhalt aus einer Inputbox in Zelle D28 schreiben, nur leider funktioniert es nicht.

Folgendes Makro: (sicherlich nicht schön geschrieben aber es bis auf die Zelle D28)

Sub erstellen()
   Dim NeuerTabellenName As String
   Dim TabellenName As Boolean
   Dim myInput As String
   Dim WsTabelle As Worksheet
   
   myInput = InputBox("Bitte geben Sie den Namen des neuen Monates an", "Monat anlegen")
   
   For Each WsTabelle In Worksheets
   If WsTabelle.Name = myInput Then
   TabellenName = True
   Exit For
   End If
   Next WsTabelle
   If TabellenName Then
   MsgBox ("Der Monat existiert bereits. Der Vorgang wurde abgebrochen. Bitte ueberpruefen Sie Ihre Eingabe.")
   Worksheets("Admin").Select
   Else
   NeuerTabellenName = myInput
   Worksheets("Muster").Copy After:=Sheets(Sheets.Count)
   Sheets(Sheets.Count).Name = NeuerTabellenName
   Worksheets("Admin").Range(D28).Value = myInput
   Worksheets("Admin").Select
   End If
End Sub

Der Fehler muss ja hier liegen:

Worksheets("Admin").Range(D28).Value = myInput

Über eine Lösung wäre ich sehr dankbar.

Gruß

...zur Frage

Excel: Code für Versenden einer Mail?

Hallo Community, wie kann ich es hinbekommen, dass die Dateinicht nur in den Postausgang gelegt wird sondern auch versendet wird? hier mein Code:

    Sub ExcelDateiSendenMitText()
Dim Nachricht As Object, OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim AWS As String
'Aktive Arbeitsmappe wird als Mail gesendet
AWS = ThisWorkbook.FullName
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = "xxxx@xxx.com; xxxxx@xxx.de"
.Subject = Range("F1") & Date & Time
.attachments.Add AWS
.Body = "text blabla"
'Hier wird die Mail nochmals angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'Mail.Send
End With
'Outlook schliessen
'OutApp.Quit
Set OutApp = Nothing
Set Nachricht = Nothing
End Sub

Ich weiß nicht weiter bitte um hilfe

Danke schon mal im Voraus

...zur Frage

Fehlermeldung in VBA: Typen unverträglich?

Hallo,

ich kriege eine Fehlermeldung in VBA, finde allerdings keine Lösung, dies zu beheben. Könnt ihr mir helfen?

Sub Berichte()
    Dim Liste As Workbook
    Dim Bericht As Workbook
    Dim Dati As Variant
    
    Set Bericht = ActiveWorkbook
    Dati = Application.GetOpenFilename("Excel-Dateien(*.xl*),*.xl*")
    Set Liste = Workbooks.Open(Filename:=Dati)
    ActiveWorkbook.Sheets("Tabelle1").Columns("A:E").Copy
    
    Windows(Bericht).Activate
    Columns("A:E").Select
    ActiveSheet.Paste

End Sub

...zur Frage

Was möchtest Du wissen?

Deine Frage stellen