Autototal i FLEX - samt mere

Det er det SUBTOTAL-funktionen er beregnet til!

Findes på fanen Data i kategorien Disposition. Funktionen er automatisk forbundet med grupperingsfunktionen, så du kan folde ud/ind.

Tak, men det er ikke så simpelt. Kan du evt. hjælpe med følgende da jeg ikke er stærk i Macro programmering.

Dette er min hoved makro:

Public WorkRowStart, WorkTitleRow, AS400TitleRow As Integer
Public RootPath As String
Public DirectoryCol As Integer
Public WorkBookingNrCol As Integer

Sub GetRows()

  Dim Kolonne As String
  Dim Indhold  As String
  Dim BookingNr, ContainerNr As String
  Dim test As String
 
  Dim NoMoreWorkRows, NoMoreAS400Rows, FoundMatch As Boolean
  NoMoreWorkRows = False
  NoMoreAS400Rows = False
  FoundMatch = False
 
  Dim WorkRow As Integer
 
  Dim WorkCol, LastWorkRow As Integer
  Dim AS400Row As Integer
  Dim AS400Col As Integer
  Dim AS400BookingNrCol, WorkContainerNrCol, AS400ContainerNrCol As Integer
  Dim MultipleContainers, Initials, ConsiderInitials As String
  Dim col, InitialsCol As Integer
 
  AS400Row = 2
  AS400Col = 1
'  Dim POD_DK_DAT, FromDate, ToDate As Long
'  On Error GoTo ErrorHandler
'  Call GetFromAS400ODBC
 
  'Get Settings values:
  WorkRowStart = Worksheets("Settings").Cells(2, 3).Value
  WorkBookingNrCol = Worksheets("Settings").Cells(3, 3).Value
  AS400BookingNrCol = Worksheets("Settings").Cells(4, 3).Value
  WorkContainerNrCol = Worksheets("Settings").Cells(5, 3).Value
  AS400ContainerNrCol = Worksheets("Settings").Cells(6, 3).Value
  RootPath = Worksheets("Settings").Cells(7, 3).Value
  DirectoryCol = Worksheets("Settings").Cells(8, 3).Value
  MultipleContainers = LCase(Worksheets("Settings").Cells(9, 3).Value)
  WorkTitleRow = Worksheets("Settings").Cells(10, 3).Value
  AS400TitleRow = Worksheets("Settings").Cells(11, 3).Value
  ConsiderInitials = Worksheets("Settings").Cells(12, 3).Value
  Initials = Worksheets("Settings").Cells(13, 3).Value
     
     
    'Refresh Data from -existing- ODBC in AS400Data Sheet
    ActiveWorkbook.RefreshAll
   
    'Get column number of INITIALS column in AS400Data Sheet
    InitialsCol = 0
    For col = 1 To 50
        If Worksheets("AS400Data").Cells(1, col).Value = "INITIALS" Then
            InitialsCol = col
            Exit For
        End If
    Next col
     
     
     
    If LCase(Worksheets("Settings").Cells(14, 3).Value) = "yes" Then
        Sheets("Work").Select
        ActiveSheet.unprotect
    End If

    'FromDate = Worksheets("Work").Cells(3, 10).Value
    'ToDate = Worksheets("Work").Cells(4, 10).Value
  While NoMoreAS400Rows = False                  'A                                    'loop through AS400 sheet bookingnr
      If Len(Worksheets("AS400Data").Cells(AS400Row, AS400BookingNrCol)) = 0 Then    'B  'Check if there is data in AS400 sheet
            NoMoreAS400Rows = True
      Else 'der er et bookingnr i as400 sheet, så find bookingnr og containernr og løb worksheet igennem
     
        'if ConsiderInitials then only loop through matching INITIALS
        If (LCase(ConsiderInitials) = "yes" And Sheets("AS400Data").Cells(AS400Row, InitialsCol).Value = Initials) Or LCase(ConsiderInitials) <> "yes" Then 'C
            '  POD_DK_DAT = Worksheets("AS400Data").Cells(AS400Row, 14).Value
            '  If POD_DK_DAT >= FromDate And POD_DK_DAT <= ToDate Then 'Check om POD_DK dato er indenfor valgt range
            FoundMatch = False
            BookingNr = Worksheets("AS400Data").Cells(AS400Row, AS400BookingNrCol).Value
            ContainerNr = Worksheets("AS400Data").Cells(AS400Row, AS400ContainerNrCol).Value
           
            WorkRow = WorkRowStart
            NoMoreWorkRows = False
            While (NoMoreWorkRows = False) And FoundMatch = False      'D                'har nu bookingnr - løb igennem work sheet rækker og led efter match, indtil match er fundet
                If Len(Worksheets("Work").Cells(WorkRow, WorkBookingNrCol).Value) = 0 Then      'E      'der er ikke noget data i feltet, så stop gennemløb da der ikke er mere at sammenligne
                    NoMoreWorkRows = True
                    LastWorkRow = WorkRow                                              'her er det tid til at indsætte den ekstra record fordi der ikke er fundet match
                        Call UpdateWorkSheet(WorkRow, AS400Row)
                        FoundMatch = True
                Else                                                                    'der er fundet data i work sheet, så sammenlign
                    If BookingNr = Worksheets("Work").Cells(WorkRow, WorkBookingNrCol).Value Then  'F    'der er fundet match på bookingnr
                        If MultipleContainers = "no" Then                            'G  'hvis der ikke skal checkes på containernr, så er match ok, opdatér work sheet
                            Call UpdateWorkSheet(WorkRow, AS400Row)                    'der er match, så kopier data fra as400 sheet til work sheet
                            FoundMatch = True
                        Else                                                            'containernr skal også matche, så check den..
                            If ContainerNr = Worksheets("Work").Cells(WorkRow, WorkContainerNrCol).Value Then    'H 'der er fundet match på container
                                Call UpdateWorkSheet(WorkRow, AS400Row)                'der er match, så kopier data fra as400 sheet til work sheet
                                FoundMatch = True
                            End If    'H                                                'match containernr
                        End If      'G 'multiplecontainers
                    End If        'F                                                      'der er fundet match på bookingnr
                End If          'E                                                        'check data i worksheet
                WorkRow = WorkRow + 1
            Wend 'D 'loop Work rows
        End If 'C 'if considerinitials
      End If 'B 'if no more as400 rows
      AS400Row = AS400Row + 1
    Wend 'A 'while NoMore AS400 rows=false
    'Worksheets("Work").Cells(5, 10).Value = Now
    '+ " (" + Environ("UserName") + ")"


ProcedureDone:
    If LCase(Worksheets("Settings").Cells(14, 3).Value) = "yes" Then
        Sheets("Work").Select
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
    End If
       
    Exit Sub

ErrorHandler:
  MsgBox "SGL:" & Err.Number & ": " & Error.Description
Resume ProcedureDone

End Sub

Sub UpdateWorkSheet(WorkRow As Integer, AS400Row As Integer)
    ' her er fundet et match, og vi har rækkenr i begge sheets
    'Dim WorkCol, AS400Col As Integer
    'Dim fs As FileSystemObject
   
    'Worksheets("Work").Cells(WorkRow, 1).Value = Worksheets("AS400Data").Cells(AS400Row, 1).Value
    'With Worksheets("Work")

       
        'URL = Worksheets("Work").Cells(3, 14).Value & Worksheets("AS400Data").Cells(AS400Row, 1).Value & "\"
      ' Worksheets("Work").Cells(WorkRow, 5).Formula = "hyperlink(" & Chr(34) & "s:\" & Chr(34) & ";" & Chr(34) & "test" & Chr(34) & ")"
    '  Worksheets("Work").Cells(WorkRow, 5).Formula = "=hyperlink(""s:\"");""test"")"
     
      '  .Hyperlinks.Add Anchor:=.Range("E" & WorkRow), _
      ' Address:=Worksheets("Work").Cells(3, 14).Value & Worksheets("AS400Data").Cells(AS400Row, 1).Value & "\", _
        'ScreenTip:=Worksheets("Work").Cells(3, 14).Value & Worksheets("AS400Data").Cells(AS400Row, 1).Value & "\", _
        'TextToDisplay:="Link: " & Worksheets("Work").Cells(3, 14).Value & Worksheets("AS400Data").Cells(AS400Row, 1).Value & "\"
    'End With
   
    For AS400Col = 1 To 40                                                                                                                'Tag 1 AS400 kolonne af gangen
        If Len(Worksheets("AS400Data").Cells(2, AS400Col).Value) > 0 Then                                                                'fortsæt kun hvis der står noget i kolonnetitel
        For WorkCol = 1 To 40                                                                                                            'løb igennen work kolonnetitler
            If Worksheets("AS400Data").Cells(AS400TitleRow, AS400Col).Value = Worksheets("Work").Cells(WorkTitleRow, WorkCol).Value Then  'Sammenlign Title Rows
                Worksheets("Work").Cells(WorkRow, WorkCol).Value = Worksheets("AS400Data").Cells(AS400Row, AS400Col).Value                'og opdater data row hvis der er match i titel
            End If
        Next
        End If
    Next
   
    'til sidst, check om directory allerede er lavet (Work sheet, col U)
    If Not LCase(Worksheets("Work").Cells(WorkRow, DirectoryCol).Value) = "yes" Then
        'hvis der ikke står yes, så lav folder:
        On Error Resume Next
     
        'MkDir "S:\BookingDocsSea.DK\" & Worksheets("Work").Cells(WorkRow, 1).Value
        MkDir RootPath & Worksheets("Work").Cells(WorkRow, WorkBookingNrCol).Value
       
        Worksheets("Work").Cells(WorkRow, DirectoryCol).Value = "Yes"
       
        'MkDir ("c:\test")
        'RmDir ("c:\test")
       
        'Set fs = CreateObject("Scripting.FileSystemObject")
        'fs.createfolder "c:\test"
       
        'Set fs = New FileSystemObject
        'fs.createfolder "c:\test"
         
       
    End If
   
   
End Sub


Har du mulighed for at fjerne unprotect/protect og tilføre følgende:

Denne som start i macroen
Sub Subtotalpå()
'
' Subtotalpå Macro
'

'
    Selection.Subtotal GroupBy:=3, Function:=xlMin, TotalList:=Array(15, 16, 17 _
        ), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub
Sub Subtotalaf()
'
' Subtotalaf Macro
'

'
    Selection.RemoveSubtotal
End Sub


Denne som sluti macroen
Sub Subtotalpå()
'
' Subtotalpå Macro
'

'
    Selection.Subtotal GroupBy:=3, Function:=xlMin, TotalList:=Array(15, 16, 17 _
        ), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub

Forresten, min subtotal viser ikke f.eks. tekst.

Hvis der står Maersk Skib ved 6 felter, kan den ikke vise samme test i subtotal. Kan man omgå dette på en måde?

Hej

Dossier  Ctnr    Cll    Kg    Volume
110471001 ABCD123 42    400  3,4
110471001 ABCD123 7      140  4,7
110471001 ABCD123 33    720  10,7
110471002 ABCD347 2      200  1,1
110471002 ABCD347 42    470  13,2

Denne opbygning har du på forhånd og sorteret på samme måde.
Det du ønsker er at får en total indsat foran hver Dossier med en sammentælling af Cll og med mulighed for at skjule detaljer - er det korrekt forstået?
Skulle i givet fald kunne konstrueres på en rimelig enkel måde.

Grunden til at jeg spørger, er at du vise en VBA-kode, som jeg ikke har nærlæst. Hvos kommer den ind i billedet?

Hej Supertekst,

Det er grundet jeg kører et protected sheet hvor der kører en VBA bagved og en "update" knap. Dvs. den er nødt til at fjerne formateringen inden den kører en update og sætte den på igen bagefter, for ellers f**cker arket op.

Tak for meldingen - det er så noget der sker for at "fabrikere" de nævnte data?

Ja præcis, det er data hentet fra et produktionssystem (andet program), som den trækker ind i excel arket. Jeg vil bare gerne samle de dataer der hører til samme "kasse" under en headline.

Du er velkommen til at fremstille en lille model af data i basisversionen og sende den. @-adressen under min profil

Hej Supertekst,

Beklager jeg først kommer retur nu. Vil gerne hvis jeg bare kan få skrevet disse ind i min Macro, så tror jeg måske godt jeg kan resten. Ved dog ikke hvordan de skal stå i macroen?

Denne som start i macroen
Sub Subtotalpå()
'
' Subtotalpå Macro
'

'
    Selection.Subtotal GroupBy:=3, Function:=xlMin, TotalList:=Array(15, 16, 17 _
        ), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub
Sub Subtotalaf()
'
' Subtotalaf Macro
'

'
    Selection.RemoveSubtotal
End Sub


Denne som slut i macroen
Sub Subtotalpå()
'
' Subtotalpå Macro
'

'
    Selection.Subtotal GroupBy:=3, Function:=xlMin, TotalList:=Array(15, 16, 17 _
        ), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub

Kan du hjælpe?

Hej Bekmand

Jeg skal prøve at se på det..

Er i tvivl om, hvad det er du søger en løsning på - men måske dette:

Så vidt jeg kan se er der behov for 2 Sub-rutiner, som du har defineret

1) SubTotalPå
2) SubTotalAf

Placer disse i bunden af din "store VBA-kode"

Kald dem så på de steder i din "store VBA-kode", hvor de skal udføres ved at anføre den ønskede Sub's navn og ikke andet.
[I andre tilfælde kan der efter navnet og et mellemrum anføres et antal parametre(adskilt af komma) - d.v.s. data som Sub-rutinen skal anvende].

Ja det er korrekt, men jeg ved ikke hvordan/hvor jeg skal sætte det ind i VBA koden. Så har du mulighed for det? Så vil jeg prøve at teste det.

Spørgsmålet er hvornår skal de 2 Sub kaldes.
Er det når der udføres en bestemt handling - f.eks. ved aktivering af en knap eller?
Eller er det et bestemt sted i forhold til din "store kode"?