Excel fryser
HeyJeg har nedenstående kode i mit Excel ark (Excel 2002 SP3 DK).
Det går ud på at jeg bare vil hente oplysninger om klientnavn og timekode ud fra nogle lister i nogle andre Excel ark.
Det virker også fint.
Men problemet er at Excel nogle gange fryser fuldstændig og bruger sindsygt CPU kraft på et eller andet - isæt hvis jeg copy/paster noget har jeg lagt mærke til.
Er der nogen som kan se om koden/makroerne er helt af helvede til og står og laver ulovligheder i baggrunden ?
..............................
Kode på hvert ark:
Private Sub worksheet_change(ByVal Target As Excel.Range)
Dim C As Range, I As Long
Dim D As Range, I2 As Long
Dim Fundet As Boolean
Dim Fundet2 As Boolean
If Not Intersect(Target, Range(kundeNrindtastes)) Is Nothing Then
If RW = 0 Then HentData ' tjekker om data er indlæst, hvis ikke hentes de
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each C In Target.Cells
Fundet = False
If Len(C) > 0 Then
For I = 1 To RW
If Data(I, 0) = C.Value Then
Cells(C.Row, C.Column + 1) = Data(I, 1)
Fundet = True
Exit For
End If
Next
If Not Fundet Then
MsgBox ("Kundernr. " + CStr(C.Value) + " kunne ikke findes!")
Range(Cells(C.Row, C.Column), Cells(C.Row, C.Column + 1)) = ""
End If
Else
Range(Cells(C.Row, C.Column), Cells(C.Row, C.Column + 1)) = ""
End If
Next
End If
If Not Intersect(Target, Range(timekodeindtastes)) Is Nothing Then
If RW2 = 0 Then HentData2 ' tjekker om data er indlæst, hvis ikke hentes de
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each D In Target.Cells
Fundet2 = False
If Len(D) > 0 Then
For I2 = 1 To RW2
If Data2(I2, 0) = D.Value Then
Cells(D.Row, D.Column + 1) = Data2(I2, 1)
Fundet2 = True
Exit For
End If
Next
If Not Fundet2 Then
MsgBox ("Timekode " + CStr(D.Value) + " kunne ikke findes!")
Range(Cells(D.Row, D.Column), Cells(D.Row, D.Column + 1)) = ""
End If
Else
Range(Cells(D.Row, D.Column), Cells(D.Row, D.Column + 1)) = ""
End If
Next
End If
...........................................
Kode i et module:
Public Const kildeSti = "H:\SHEETS\SR\Klientliste.xls"
Public Const kildeSti2 = "H:\SHEETS\SR\Timekoder.xls" 'tilpasses
Public kXLS, kildeRækker, Rækker As Integer
Public kildeRækker2, Rækker2 As Integer
Public RW As Long
Public RW2 As Long
Public Data() As Variant
Public Data2() As Variant
Public Const kundeNrindtastes = "C10:C100,J10:J100"
Public Const timekodeindtastes = "E10:E100,L10:L100"
Function HentData()
Set kXLS = CreateObject("Excel.application")
Dim Sh As Worksheet
Dim Temp As Variant
With kXLS
.Workbooks.Open kildeSti
For Each Sh In .Worksheets 'NY
With Sh
.Activate
kildeRækker = kildeRækker + .Range("A65536").End(xlUp).Row ' tæller hvor mange data rækker, der er ialt
End With
Next
ReDim Data(kildeRækker, 5) ' klargør arrayet til at indeholde data, med 6 kolonner i
RW = 0 ' første kolonne hedder 0
For Each Sh In .Worksheets
With Sh
Rækker = .Range("A65536").End(xlUp).Row
Temp = .Range("A1:E" & Rækker)
For R = 1 To Rækker
If IsNumeric(Temp(R, 1)) Then
RW = RW + 1
For I = 1 To 5
Data(RW, I - 1) = Temp(R, I) ' lægger data ind i array
Next
End If
Next
End With
Next
End With
lukObject
End Function
Function HentData2()
Set kXLS = CreateObject("Excel.application")
Dim Sh As Worksheet
Dim Temp2 As Variant
With kXLS
.Workbooks.Open kildeSti2
For Each Sh In .Worksheets 'NY
With Sh
.Activate
kildeRækker2 = kildeRækker2 + .Range("A65536").End(xlUp).Row ' tæller hvor mange data rækker, der er ialt
End With
Next
ReDim Data2(kildeRækker2, 5) ' klargør arrayet til at indeholde data, med 6 kolonner i
RW2 = 0 ' første kolonne hedder 0
For Each Sh In .Worksheets
With Sh
Rækker2 = .Range("A65536").End(xlUp).Row
Temp2 = .Range("A1:E" & Rækker2)
For R = 1 To Rækker2
If IsNumeric(Temp2(R, 1)) Then
RW2 = RW2 + 1
For I2 = 1 To 5
Data2(RW2, I2 - 1) = Temp2(R, I2) ' lægger data ind i array
Next
End If
Next
End With
Next
End With
lukObject
End Function
Public Sub lukObject()
With kXLS
.ActiveWorkbook.Close
.Application.Quit
End With
Set kXLS = Nothing
End Sub
