26. maj 2008 - 10:12Der er
12 kommentarer og 1 løsning
VBA / Macro til afløsning af Lopslag
Hej
Jeg har et Lopslag, som virker som det skal, men det dræber mit excelark.
Jeg har et ark, med lige pt. 6305 linier hvor jeg skal tjekke om linien er i et andet ark.
Arket som det tjekker op imod, bliver fødet af data via en macro, og macroen slutter med at indsætte et lopslag i alle 6305 rækker.
Det fungere bare ikke mere, min computer kan ikke trække det, selvom det er en C2D 2,4 GHz Windows XP Pro med 3 gb 667 MHz DDr2 ram
Det som jeg skal bruge, er at hvis række E findes i mit samleark, række B skal det retunere "Noget tekst" og hvis den findes i række C skal den returnere "Nogen andet tekst" og hvis ikke "Noget trejde tekst"
Disse tekster er ikke noget der skal hentes, blot noget jeg selv definere.
Denne side indeholder artikler med forskellige perspektiver på Identity & Access Management i private og offentlige organisationer. Artiklerne behandler aktuelle IAM-emner og leveres af producenter, rådgivere og implementeringspartnere.
Sub CollectData() Dim wks As Worksheet, NextRow As Integer Application.Calculation = xlManual Application.ScreenUpdating = False Sheets("Totalliste").Select rknr = Range("A65536").End(xlUp).Row Range("A2:E" & rknr).Select Selection.Delete Shift:=xlUp For Each wks In Worksheets If Not (wks.Name = ("Totalliste") Or wks.Name = ("Samtlige lokationer")) Then wks.Activate Range("A2:e2").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Worksheets("Totalliste").Activate NextRow = Range("A65536").End(xlUp).Row + 1 Cells(NextRow, 1).Activate ActiveSheet.Paste End If Next wks
Sub CollectData() Start = Now() Dim wks As Worksheet, NextRow As Integer Application.Calculation = xlManual Application.ScreenUpdating = False Sheets("Totalliste").Select rknr = Range("A65536").End(xlUp).Row Range("A2:E" & rknr).Delete Shift:=xlUp ' ***** lavet om så intet selectes, det øger hastigheden For Each wks In Worksheets If Not (wks.Name = ("Totalliste") Or wks.Name = ("Samtlige lokationer")) Then If wks.Range("A2") <> "" Then wks.Range(wks.Range("A2:e2"), wks.Range("A2:e2").End(xlDown)).Copy _ Worksheets("Totalliste").Range("A65536").End(xlUp).Offset(1, 0) End If End If Next wks
svar = Array("NEJ", "JA", "JA") ' Svar muligheder Data1 = Range(Range("B2"), Range("E65536").End(xlUp)) ' kolonne B og E i en variabel Sheets("Samtlige lokationer").Select Data2 = Range(Range("E2"), Range("E65536").End(xlUp)) ' kolonne E i en variabel Data3 = Range(Range("f2"), Range("E65536").End(xlUp).Offset(0, 1)) ' kolonne F med tomme celler i en variabel
For x = 1 To UBound(Data2) For i = 1 To UBound(Data1) If Data1(i, 1) = Data2(x, 1) Then ' tjekker kolonne B op mod kolonne E Data3(x, 1) = svar(2) ' hvis fundet i kolonne B, skrives svar(2) i Data3 Exit For End If Next If IsEmpty(Data3(x, 1)) Then For i = 1 To UBound(Data1) If Data1(i, 2) = Data2(x, 1) Then ' tjekker kolonne C op mod kolonne E Data3(x, 1) = svar(1) ' hvis fundet i kolonne C, skrives svar(1) i Data3 Exit For End If Next End If If IsEmpty(Data3(x, 1)) Then Data3(x, 1) = svar(0) ' hvis Ikke i kolonne B eller C, skrives svar(0) i Data3
Next
Range(Range("f2"), Range("E65536").End(xlUp).Offset(0, 1)) = Data3 ' skriver i F kolonnen Application.ScreenUpdating = True Application.Calculation = xlAutomatic MsgBox " Udført på " & Format(Now() - Start, "nn:ss") & " minutter" End Sub
Noget er galt, den returnere kun svarene JA og NEJ selvom jeg har rettet svar = Array("NEJ", "JA", "JA") ' Svar muligheder til svar = Array("NEJ", "MIX", "JA") ' Svar muligheder
meningen er, at Sheet("Samlige lokationer").Range("F") skal skrive JA hvis Sheet("Samlige lokationer").Range("E") findes i Sheet("Totalliste").Range("B") og den skal skrive MIX hvis den findes i Sheet("Totalliste").Range("C")
Det kom jeg i tanke om, efter jeg havde lukket i går, jeg manglede en linje.
Data3(x, 1) = Empty
den er sat ind i koden nedenunder
Sub CollectData() Start = Now() Dim wks As Worksheet, NextRow As Integer Application.Calculation = xlManual Application.ScreenUpdating = False Sheets("Totalliste").Select rknr = Range("A65536").End(xlUp).Row Range("A2:E" & rknr).Delete Shift:=xlUp ' ***** lavet om så intet selectes, det øger hastigheden For Each wks In Worksheets If Not (wks.Name = ("Totalliste") Or wks.Name = ("Samtlige lokationer")) Then If wks.Range("A2") <> "" Then wks.Range(wks.Range("A2:e2"), wks.Range("A2:e2").End(xlDown)).Copy _ Worksheets("Totalliste").Range("A65536").End(xlUp).Offset(1, 0) End If End If Next wks
svar = Array("NEJ", "JA", "JA") ' Svar muligheder Data1 = Range(Range("B2"), Range("E65536").End(xlUp)) ' kolonne B og E i en variabel Sheets("Samtlige lokationer").Select Data2 = Range(Range("E2"), Range("E65536").End(xlUp)) ' kolonne E i en variabel Data3 = Range(Range("f2"), Range("E65536").End(xlUp).Offset(0, 1)) ' kolonne F med tomme celler i en variabel
For x = 1 To UBound(Data2) Data3(x, 1) = Empty For i = 1 To UBound(Data1) If Data1(i, 1) = Data2(x, 1) Then ' tjekker kolonne B op mod kolonne E Data3(x, 1) = svar(2) ' hvis fundet i kolonne B, skrives svar(2) i Data3 Exit For End If Next If IsEmpty(Data3(x, 1)) Then For i = 1 To UBound(Data1) If Data1(i, 2) = Data2(x, 1) Then ' tjekker kolonne C op mod kolonne E Data3(x, 1) = svar(1) ' hvis fundet i kolonne C, skrives svar(1) i Data3 Exit For End If Next End If If IsEmpty(Data3(x, 1)) Then Data3(x, 1) = svar(0) ' hvis Ikke i kolonne B eller C, skrives svar(0) i Data3
Next
Range(Range("f2"), Range("E65536").End(xlUp).Offset(0, 1)) = Data3 ' skriver i F kolonnen Application.ScreenUpdating = True Application.Calculation = xlAutomatic MsgBox " Udført på " & Format(Now() - Start, "nn:ss") & " minutter" End Sub
Det vi skal koncentrere os om, er arket "Samtlige lokationer" Her har du lavet macrokoden, som skulle afsløse mit Lopslag
Din macrokode indsætter data i Kollone F og mit Lopslag er i Kollone G Disse skulle gerne stemme overens, men der er en fejl et sted.
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.
