Új hozzászólás Aktív témák

• #13511 föccer nagyúr

  Új Válasz 2025-03-12 21:46:27 #13511

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  föccer

  nagyúr

  Sub JelentesKeszites()
    Dim ws As Worksheet, alapadatok As Worksheet, borito As Worksheet
    Dim rng As Range, cell As Range
    Dim dict As Object, receptDict As Object
    Dim receptSzam As String, receptCount As Object
    Dim lastRow As Long, wsEE As Worksheet
    Dim minValue As Double, maxValue As Double, avgValue As Double
    Dim pdfFileName As String, pdfPath As String
    Dim i As Integer, j As Integer
    Dim valasztottUzem As String
    Dim osszesMinta As Integer
    
    ' Alapadatok munkalap beállítása
    Set alapadatok = ThisWorkbook.Sheets("Alapadatok")
    Set borito = ThisWorkbook.Sheets("Borító")
    lastRow = alapadatok.Cells(Rows.Count, 1).End(xlUp).Row
    
    ' Egyedi üzemek összegyűjtése
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 2 To lastRow
        If Not dict.exists(alapadatok.Cells(i, 1).Value) Then
            dict.Add alapadatok.Cells(i, 1).Value, Nothing
        End If
    Next i
    
    ' Üzemek listája ellenőrzése
    If dict.Count = 0 Then
        MsgBox "Nincs elérhető üzem az adatokban!", vbExclamation
        Exit Sub
    End If
    
    ' UserForm megjelenítése az üzem kiválasztásához
    valasztottUzem = UzemValasztasForm.ShowForm(dict.keys)
    If valasztottUzem = "" Then Exit Sub
    
    ' Megerősítő kérdés
    If MsgBox("Indulhat a jelentés generálása?", vbYesNo + vbQuestion) <> vbYes Then Exit Sub
    
    ' Receptszámok összegyűjtése és számlálása
    Set receptDict = CreateObject("Scripting.Dictionary")
    Set receptCount = CreateObject("Scripting.Dictionary")
    osszesMinta = 0
    
    For i = 2 To lastRow
        If alapadatok.Cells(i, 1).Value = valasztottUzem Then
            receptSzam = alapadatok.Cells(i, 2).Value
            osszesMinta = osszesMinta + 1
            If Not receptDict.exists(receptSzam) Then
                receptDict.Add receptSzam, Nothing
                receptCount.Add receptSzam, 1
            Else
                receptCount(receptSzam) = receptCount(receptSzam) + 1
            End If
        End If
    Next i
    
    ' Receptek sorrendbe állítása darabszám szerint
    Dim sortedRecepts As Variant
    sortedRecepts = receptCount.keys
    For i = LBound(sortedRecepts) To UBound(sortedRecepts) - 1
        For j = i + 1 To UBound(sortedRecepts)
            If receptCount(sortedRecepts(j)) > receptCount(sortedRecepts(i)) Then
                Dim temp As String
                temp = sortedRecepts(i)
                sortedRecepts(i) = sortedRecepts(j)
                sortedRecepts(j) = temp
            End If
        Next j
    Next i
    
    ' EE munkalapokra másolás
    For i = 0 To Application.Min(UBound(sortedRecepts), 19)
        If receptCount(sortedRecepts(i)) >= 3 Then
            Set wsEE = ThisWorkbook.Sheets("EE_" & (i + 1))
            wsEE.Visible = xlSheetVisible
            ' Adatok másolása EE munkalapokra
            Dim rowIndex As Integer
            rowIndex = 12
            For j = 2 To lastRow
                If alapadatok.Cells(j, 1).Value = valasztottUzem And alapadatok.Cells(j, 2).Value = sortedRecepts(i) Then
                    wsEE.Cells(rowIndex, 1).Resize(, 4).Value = alapadatok.Cells(j, 1).Resize(, 4).Value
                    rowIndex = rowIndex + 1
                End If
            Next j
        End If
    Next i
    
    ' Borító munkalap kitöltése
    borito.Cells(1, 1).Value = "Dátum:"
    borito.Cells(1, 2).Value = Now
    borito.Cells(2, 1).Value = "Üzem:"
    borito.Cells(2, 2).Value = valasztottUzem
    borito.Cells(3, 1).Value = "Minták száma:"
    borito.Cells(3, 2).Value = osszesMinta
    borito.Cells(8, 1).Value = "Receptszám"
    borito.Cells(8, 2).Value = "Minták száma"
    borito.Cells(8, 3).Value = "Minimum"
    borito.Cells(8, 4).Value = "Maximum"
    borito.Cells(8, 5).Value = "Átlag"
    
    ' PDF exportálás kizárólag a szükséges munkalapokkal
    pdfFileName = Format(Now, "yyyymmdd") & "_" & valasztottUzem & ".pdf"
    pdfPath = ThisWorkbook.Path & "\" & pdfFileName
    
    Dim sheetsToExport As Variant
    sheetsToExport = Array("Borító")
    For i = 1 To 20
        On Error Resume Next
        If ThisWorkbook.Sheets("EE_" & i).Visible = xlSheetVisible Then
            ReDim Preserve sheetsToExport(UBound(sheetsToExport) + 1)
            sheetsToExport(UBound(sheetsToExport)) = "EE_" & i
        End If
        On Error GoTo 0
    Next i
    
    ThisWorkbook.Sheets(sheetsToExport).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath, OpenAfterPublish:=True
    
    MsgBox "A jelentés elkészült és mentve lett PDF-ben!", vbInformation
    
    End Sub

Új hozzászólás Aktív témák