Kan Makroen ændre

øøh, hvad skal den ændres til ?

Lytter lige med

jlemming
Her er de bemærkninger jeg skulle havde haft med:
Jeg har filen AlleProjekt med arket Projekt Total, hvor Makroen i kolonne
A skriver nr., i kolonne E timer og i kolonne F overtimer.

Nr., timer og overtimer hentes f.eks. i en af mange filer med navnet
OpgørelseXXXX2005 osv., det betyder at Makroen undersøger alle filer
med navnet OpgørelseXXXX2005 for ens nr. de timer de forskellige
firmaer har brugt SUMMES og skrives i kolonne E og F som nævnt
ovenfor.

Det jeg nu gerne vil have Makroen til er:
Makroen undersøger f.eks. filen OpgørelseXXXX2005 har et nr, er
det tilfældet skrives nr. i kolonne A, i kolonne E timer og i kolonne F overtimer. i
filen AlleProjekter og i kolonne G vil jeg gerne have firmanavnet fra OpgørelseXXXX2005
der står i arket Opgørelse2005 A2:B2.
Med andre ord, vil jeg gerne have nr. timer og overtimer ud for det enkelte firma.

Makroen samler data ind for er bestemt periode bestemt af: F1 (rWeekFrom),
F2 (rWeekTo) og  D1 (rYear).

Programkode i Ark Projekt Total

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   
    ' Begge uger og året skal være tal
    If Not Intersect(Target, Range("D1,F1:F2")) Is Nothing Then
        If Not (IsNumeric(Target.Value)) Then
            Application.EnableEvents = False
            MsgBox "Her skal stå et TAL...!", _
                  vbExclamation + vbOKOnly, "Systeminformation"
            Target.Value = ""
            Target.Select
            Application.EnableEvents = True
        End If
    End If
       
    ' Fra Uge skal være mindre end Til Uge
    If Not Intersect(Target, Range("F1")) Is Nothing Then
        If Not (Range("F2").Value = "") Then
            If Not (Range("F1").Value < Range("F2").Value) Then
                Application.EnableEvents = False
                MsgBox "FraUge SKAL være et mindre ugenr. end TilUge", _
                      vbExclamation + vbOKOnly, "Systeminformation"
                Target.Value = ""
                Target.Select
                Application.EnableEvents = True
            End If
        End If
    End If
   
    ' Til Uge skal være større end Fra Uge
    If Not Intersect(Target, Range("F2")) Is Nothing Then
        If Not (Range("F2").Value > Range("F1").Value) Then
            Application.EnableEvents = False
            MsgBox "TilUge SKAL være et større ugenr. end FraUge", _
                  vbExclamation + vbOKOnly, "Systeminformation"
            Target.Value = ""
            Target.Select
            Application.EnableEvents = True
        End If
    End If
   
End Sub

alicev
Dinne Makroer ligner til forveksling dem  bak  stod
fader til i 2002-2005 sammen med en mere som jeg ikke
husker navnet på, sådan er det når man er fra før 2.
verdenskrig.
johnfm

Har du mulighed for sende de 2 filer, har lidt problemer med at gennemskue koden

Må det fylde ca. 5MB

Jeg har sendt tre filer.

Jeg har sendt tre "NYE" filer

jlemming
Har du modtaget mine mails.
alicev

ok, Jeg kigger på de nye filer, senere idag

prøver et nyt spørgsmål

Hvorfor har du selv taget pointene??

nåå, det er fordi jeg jo slet ikke har svaret. Jeg ved ikke lige der er sket mandag morgen??, jeg havde rettet din kode til, og lagt den herind, meeen af en eller anden årsag er den her jo ikke. og samtidig har jeg ikke gemt filen!!! :-(

Dette skal jeg selvfølig beklage!!

Der er her:


Option Explicit

Private Const msJOB_NR_MED_TEKST As String = "JOBnrMed_Tekst.xls"
Private mvntFiles As Variant
Private mwkBook As Workbook
Private mwkSheet As Worksheet
Private mvntProjects() As Variant
Private mlProjectCount As Long
Private mlProjectFound As Long
Private mlColFrom As Long
Private mlColTo As Long

Public Sub ProjectTotal()
    Dim sFileSeachPath As String
    Dim lCount As Long
    Dim sYear As String 'ghlkjk
    Dim sWeekFrom As String
    Dim sWeekTo As String
    Dim rCurReg As Range
    Dim rCell As Range

    ' Prevent application or user interrupt
    With Application
        .EnableCancelKey = xlDisabled
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    ' CleanUp
    With wksProject.Range("rStart")
        On Error Resume Next
        .AutoFilter
        On Error GoTo 0
        On Error GoTo NoCurrentRegionFound
        Set rCurReg = .CurrentRegion
        Set rCurReg = rCurReg.Offset(1, 0).Resize(rCurReg.Rows.Count - 1)
        rCurReg.ClearContents
NoCurrentRegionFound:
        Set rCurReg = Nothing
    End With
   
    ' Establish filearray
    sFileSeachPath = ThisWorkbook.Path & "\"
    mvntFiles = GetFileList(sFileSeachPath & "Opgorelse*.xls")
   
    ' User specifications in sheet
    With wksProject
        sYear = .Range("rYear").Value
        sWeekFrom = .Range("rWeekFrom").Value
        sWeekTo = .Range("rWeekTo").Value
    End With
   
    Select Case IsArray(mvntFiles)
        Case True ' Files found
            mlProjectCount = 0
           
            For lCount = LBound(mvntFiles) To UBound(mvntFiles)
                ' Open next workbook
                Set mwkBook = Application.Workbooks.Open(FileName:=sFileSeachPath & mvntFiles(lCount))
                Set mwkSheet = mwkBook.Sheets(1)
               
                ' Witch columns to run through
                DeterminColumns sWeekFrom, sWeekTo
               
                ' Run trough project numbers
                CalculateProjects
               
                ' Close Workbook
                mwkBook.Close SaveChanges:=False
            Next lCount
        Case False ' No files found
            MsgBox "No matching files"
            GoTo CleanUp
    End Select
   
    ' Insert mvntFiles information to sheet
    With wksProject
        With .Range("rStart")
            For lCount = LBound(mvntProjects, 2) To UBound(mvntProjects, 2)
                If Not (CDbl(mvntProjects(1, lCount)) + CDbl(mvntProjects(2, lCount)) = 0) Then
                    .Offset(lCount + 1, 0).Value = mvntProjects(0, lCount)
                    .Offset(lCount + 1, 4).Value = CDbl(mvntProjects(1, lCount))
                    .Offset(lCount + 1, 5).Value = CDbl(mvntProjects(2, lCount))
                    .Offset(lCount + 1, 6).Value = mvntProjects(3, lCount)
                End If
            Next lCount
        End With
       
        ' Delete empty rows
        For lCount = .Range("A65536").End(xlUp).Row To .Range("rStart").Row Step -1
            If .Cells(lCount, 1).Value = "" Then
                .Cells(lCount, 1).EntireRow.Delete
            End If
        Next lCount
    End With
   
   
    ' Get project informations
    sFileSeachPath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\"))
    Set mwkBook = Application.Workbooks.Open(FileName:=sFileSeachPath & msJOB_NR_MED_TEKST)
    Set mwkSheet = mwkBook.Sheets(1)
   
    Set rCurReg = wksProject.Range("rStart").CurrentRegion
    If Not (rCurReg.Rows.Count = 1) Then
        Set rCurReg = rCurReg.Offset(1, 0).Resize(rCurReg.Rows.Count - 1)
        For Each rCell In rCurReg.Columns(1).Cells
            With rCell
                For lCount = 1 To mwkSheet.Range("A1").CurrentRegion.Rows.Count
                    If Trim$(UCase(CStr(.Value))) = Trim$(UCase(CStr(mwkSheet.Cells(lCount, 1).Value))) Then
                        .Offset(0, 1).Value = mwkSheet.Cells(lCount, 2).Value
                        .Offset(0, 2).Value = mwkSheet.Cells(lCount, 4).Value
                        .Offset(0, 3).Value = mwkSheet.Cells(lCount, 5).Value
                        Exit For
                    End If
                Next lCount
            End With
        Next rCell
    End If
    mwkBook.Close SaveChanges:=False
   
    ' Layout
    Application.ScreenUpdating = True
    With wksProject.Range("rStart")
        '.CurrentRegion.Columns.AutoFit
        .Select
        Selection.AutoFilter
    End With
   
CleanUp:
    Set mwkSheet = Nothing
    Set mwkBook = Nothing
    Erase mvntProjects()
    With Application
        .EnableCancelKey = xlInterrupt
        .EnableEvents = True
    End With
End Sub

Private Sub CalculateProjects()
    ' Add unike projects and calculate found projects
    Dim lCol As Long
    Dim lRow As Long
   
    ReDim Preserve mvntProjects(0 To 3, 0 To mlProjectCount)
    With mwkSheet
        For lCol = mlColFrom To mlColTo Step 3
            For lRow = 4 To 53
                With .Cells(lRow, lCol)
                    If Not (.Value = 0) Then
                        mvntProjects(3, mlProjectCount) = mwkSheet.Range("A1").Value
                        If Not (ProjectExists(.Value)) Then
                            mvntProjects(0, mlProjectCount) = .Value
                            If IsNumeric(.Offset(0, 1).Value) Then
                                mvntProjects(1, mlProjectCount) = CDbl(.Offset(0, 1).Value)
                            Else
                                mvntProjects(1, mlProjectCount) = 0
                            End If
                            If IsNumeric(.Offset(0, 2).Value) Then
                                mvntProjects(2, mlProjectCount) = CDbl(.Offset(0, 2).Value)
                            Else
                                mvntProjects(2, mlProjectCount) = 0
                            End If
                            mlProjectCount = mlProjectCount + 1
                            ReDim Preserve mvntProjects(0 To 3, 0 To mlProjectCount)
                        Else
                            If IsNumeric(.Offset(0, 1).Value) Then
                                mvntProjects(1, mlProjectFound) = CDbl(mvntProjects(1, mlProjectFound)) + _
                                                                CDbl(.Offset(0, 1).Value)
                            End If
                            If IsNumeric(.Offset(0, 2).Value) Then
                                mvntProjects(2, mlProjectFound) = CDbl(mvntProjects(2, mlProjectFound)) + _
                                                                CDbl(.Offset(0, 2).Value)
                            End If
                        End If
                    End If
                End With
            Next lRow
        Next lCol
    End With
End Sub

Private Function ProjectExists(ByRef ProjectNum As Variant) As Boolean
    ' True if the project already is created
    Dim bRetVal As Boolean
    Dim lCount As Long
   
    mlProjectFound = 0
    bRetVal = 0
    On Error GoTo ProgErr
    For lCount = LBound(mvntProjects, 2) To UBound(mvntProjects, 2)
        If ProjectNum = mvntProjects(0, lCount) Then
            mlProjectFound = lCount
            bRetVal = True
            Exit For
        End If
    Next lCount

ProgErr:
    ProjectExists = bRetVal
End Function

Private Sub DeterminColumns(ByRef sFrom As String, sTo As String)
    ' Find columns of start and end weeks
    Dim rCell As Range
   
    For Each rCell In mwkSheet.Range("D1").CurrentRegion.Rows(1).Cells
        With rCell
            If Right$(.Value, 2) = Format(sFrom, "00") Then
                mlColFrom = .Column
            End If
            If Right$(.Value, 2) = Format(sTo, "00") Then
                mlColTo = .Column
                Exit For
            End If
        End With
    Next rCell
   
    Set rCell = Nothing
End Sub

Private Function GetFileList(ByRef FileSpec As String) As Variant
    ' Returns an array of sFileNames that match FileSpec
    ' If no matching files are found, it returns False
    Dim vntFileArray() As Variant
    Dim lFileCount As Long
    Dim sFileName As String
   
    On Error GoTo NoFilesFound

    lFileCount = 0
    sFileName = Dir(FileSpec)
    If sFileName = "" Then GoTo NoFilesFound
   
    ' Loop until no more matching files are found
    Do While sFileName <> ""
        lFileCount = lFileCount + 1
        ReDim Preserve vntFileArray(1 To lFileCount)
        vntFileArray(lFileCount) = sFileName
        sFileName = Dir()
    Loop
    GetFileList = vntFileArray
    Exit Function

    ' Error handler
NoFilesFound:
    GetFileList = False
End Function