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
'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
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
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
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?
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.
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.
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
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].
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"?
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
