Hjælp til at ændre en Makro

Bak har ifølge johnfm stået fader til følgende Makro, det jeg ønsker hjælp til er:

I filen AlleProjekter Ark Projekt Total i D1 bestemmes året,
i F1 bestemmes Fra uge, i F2 bestemmes Til uge.

I kolonne A skrives ProjektNr., i kolonne E skrives timer, kolonne F skrives overtimer og i kolonne G skrives Firmanavn.

Dataene hentes i filen OpgorelseFirmanavn2008 som der er ca. 40
Forskellige af.
I f.eks. uge 01 hentes projektnr i D4:D53, timer i E4:E53,
overtimer i F4:F53, det slutter med uge 53  FF4:FF53.
Firmanavnet hentes i A1:B2.

Filen JOBnrMed_Tekst skal ikke være i brug mere.

I kolonne A, i kolonne E, kolonne F og Kolonne G.
40000056        7,5          2            FirmaXX:

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))
                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 2, 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
                        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 2, 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

Programkode:

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