08. oktober 2008 - 22:44Der er
20 kommentarer og 1 løsning
hente data fra andet ark og tilbage igen.
Jeg har fået hjælp til denne makro, der henter data fra et ark til et andet.
Nu kunne jeg godt bruge en lille rettelse/tilføjelse. Når den henter linjerne vil jeg gerne have at den fanger det linjenr. i arket 2008 som den henter data fra og indsætter dette nr. i kol T i det ark der hentes til.
Jeg er med på at de data den fanger i arket 2008 indsættes her: ThisWorkbook.Sheets("2008").Cells.Range("A" & intI & ":Q" & intI).Copy ThisWorkbook.Sheets("IgangvSpec").Range("A" & intJ) ThisWorkbook.Sheets("IgangvSpec").Range("S" & intJ) = "X"
Men den skal altså også indsætte det linjenr. den har hentet data fra i i kol T.
HVAD SKAL DET BRUGES TIL? Grunden til at jeg gerne vil have linje nr indsat i de hentede linjer er at jeg efterfølgende skal have en makro der gør følgende:
Kigger i arket igangvspec i kol S. Alle de linjer som har "X" i denne kolonne skal rettes i det oprindelige ark "2008". Det eneste der skal rettes i linjen er at kol F i ark 2008 skal sættes til "Ja"
Her har jeg tænkt mig at den skal bruge det linjenr. der står i kol T til at identificere de linjer der er rettet.
Problem 1/makro1: Indsætte oprindfeligt linjenr. i de hentede linjer fra ark 2008 i kol T
Problem 2/makro2: Finde den tilsvarende linje i arket 2008 til alle de linjer der er markeret med X i arket "igangvspec" og sætte Cellen i kol F til "Ja"
Lidt kringlet, men håber på at det er forståeligt.
Sub IgangvSpec_hent_åbne_poster() Application.ScreenUpdating = False Dim intI As Integer Dim intJ As Integer
intJ = 5 Do Until (ThisWorkbook.Sheets("IgangvSpec").Cells.Range("B" & intJ) = "") intJ = intJ + 1 Loop
For intI = 5 To 25000 If (ThisWorkbook.Sheets("2008").Cells.Range("B" & intI) = ThisWorkbook.Sheets("faktura").Range("faktura_kundenr") _ And ThisWorkbook.Sheets("2008").Cells.Range("F" & intI) <> "Ja") Then ThisWorkbook.Sheets("2008").Cells.Range("A" & intI & ":Q" & intI).Copy ThisWorkbook.Sheets("IgangvSpec").Range("A" & intJ) ThisWorkbook.Sheets("IgangvSpec").Range("S" & intJ) = "X" intJ = intJ + 1 End If Next intI End Sub
ups det får du nok ikke meget ud af, havde rettet i koden du får lige hele min kode
Sub Spec_hent() Application.ScreenUpdating = False Dim intI As Integer Dim intJ As Integer
Set shSpec = ThisWorkbook.Sheets("IgangvSpec") Set sh2008 = ThisWorkbook.Sheets("2008") Set shFak = ThisWorkbook.Sheets("faktura")
intJ = 5 Do Until (shSpec.Cells.Range("B" & intJ) = "") intJ = intJ + 1 Loop
For intI = 5 To 25000 If sh2008.Cells.Range("B" & intI) = shFak.Range("faktura_kundenr") And sh2008.Cells.Range("F" & intI) <> "Ja" Then sh2008.Cells.Range("A" & intI & ":Q" & intI).Copy shSpec.Range("A" & intJ) shSpec.Range("S" & intJ) = "X" shSpec.Range("T" & intJ) = intI intJ = intJ + 1 End If Next intI End Sub
jep, nu er første del på plads. Jeg har lige rettet en lille smule i koden, sådan at linjenr også bliver indsat i både arket 2008 + igangvspec. (ved ikke om det er nødvendigt)
STEP2 skal gøre følgende: De linjer jer har fået overført til igangvspec har som udgangspunkt alle et "X" i kol. S.
I kolonne T står der desuden det "linjenr" som indholder de samme data i arket "2008".
Nu skal den nye makro finde de linjer der står i "igangvspec" ovre i "2008". Hvis der står X i kol S i arket igangvspec så skal kol F i arket 2008 sættes til "Ja" Hvis IKKE der står X i kol S i arket igangvspec så skal der ikke gøres noget.
Jeg regner med at linjenr som er indsat i kol T kan være med til at identificere hvilke linjer der er identiske.
Sub IgangvSpec_hent_åbne_poster2()
Application.ScreenUpdating = False Dim intI As Integer Dim intJ As Integer
Set shSpec = ThisWorkbook.Sheets("IgangvSpec") Set sh2008 = ThisWorkbook.Sheets("2008") Set shFak = ThisWorkbook.Sheets("faktura")
intJ = 5 Do Until (shSpec.Cells.Range("B" & intJ) = "") intJ = intJ + 1 Loop
For intI = 5 To 25000 If sh2008.Cells.Range("B" & intI) = shFak.Range("faktura_kundenr") And sh2008.Cells.Range("F" & intI) <> "Ja" Then ThisWorkbook.Sheets("2008").Cells.Range("S" & intI) = intI sh2008.Range("T" & intI) = intI sh2008.Cells.Range("A" & intI & ":T" & intI).Copy shSpec.Range("A" & intJ) shSpec.Range("S" & intJ) = "X" intJ = intJ + 1 End If Next intI
Jeg kan ikke afprøve om det virker her, så men prøv denne
Sub Spec_hent() Application.ScreenUpdating = False Dim intI As Integer Dim intJ As Integer
Set shSpec = ThisWorkbook.Sheets("IgangvSpec") Set sh2008 = ThisWorkbook.Sheets("2008") Set shFak = ThisWorkbook.Sheets("faktura")
intJ = 5 Do Until shSpec.Range("B" & intJ) = "" intJ = intJ + 1 Loop
For intI = 5 To 25000 If sh2008.Range("B" & intI) = shFak.Range("faktura_kundenr") And sh2008.Range("F" & intI) <> "Ja" Then sh2008.Range("A" & intI & ":Q" & intI).Copy shSpec.Range("A" & intJ) shSpec.Range("S" & intJ) = "X" shSpec.Range("T" & intJ) = intI intJ = intJ + 1 End If If shSpec.Range("S" & intI) = "X" Then sh2008.Range("F" & intI) = "ja" End If Next intI End Sub
Det er ikke helt sådan jeg ønskede det. Men det er vist fordi jeg ikke får forklaret mig ordentligt.
Den første makro du lavede er nu på plads. Nu skal vi have en anden makro der gøre noget andet.
Her kommer forklaringen: 1. Der hentes en masse linjer fra arket 2008 til iganvspec. Det kan være alt fra 1 til 100 linjer der flyttes. I kolonne F står der altid JA i de linjer som er hentet. I kolonne S har jeg fået indsat et "X" i alle linjer. I kolonne T har jeg fået indsat det linjenr. hvor linjer oprindeligt kommer fra i arket 2008
2. Så retter jeg lidt i linjerne i arket igangvspec (jeg fjerner nogle af "x"érne i kol S
3. Nu ønsker jeg så en ny makro der tager alle de linjer som er i arket igangvspec som har et "X" i kol S og finder de samme i arket 2008 og ændrer kolonne F fra NEJ til JA. I kolonne T i igangvspec har jeg fået indsat det oprindelige linjenr fra arket 2008 og jeg regner med at man kan bruge det nr. til at finde den oprindelige linje igen i arket 2008, nå der skal sættes et JA i kolonne F der.
Jeg vil tro at den skal se nogenlunde sådan ud, men det er ikke helt rigtigt.
Sub Spec_retur() Application.ScreenUpdating = False Dim intI As Integer Dim intJ As Integer
Set shSpec = ThisWorkbook.Sheets("IgangvSpec") Set sh2008 = ThisWorkbook.Sheets("2008")
intJ = 5 Do Until shSpec.Range("B" & intJ) = "" intJ = intJ + 1 Loop
For intI = 5 To 25000 If shspec.Range("S" & intI) = "X" Then sh2008.Range("F" & intI) = "ja" End If Next intI End Sub
ja, nu gør den lige det jeg gerne vil have den til. Men den er rimelig langsom i det den gør.
Hvis der er 4 poster i arket igangvspec tager den ca 5 sekunder at køre denne makro. Jeg kan ikke rigtig se hvorfor den tager så "lang" tid. Ved flere poster, (som der typisk er" vil det blive til rimelig lang vente tid.
Der er typsik 2-100 linjer i arket igangvspec, som skal rettes. Der er min. 20.000 linjer i arket 2008.
Men det burde vel ikke gøre koden langsom, da den får "foræret" hvilket linje den skal rette i arket 2008, udfra hvad der står i kolonne T.
Hvis den ikke kan blive hurtigere er det også ok, du har jo løst mit problem. Jeg kan evt sende en mail med arket for at du nemmere kan se hvad jeg mener
Sub Spec_retur() Dim RW As Long, Data1 As Variant Dim intI As Integer
RW = ThisWorkbook.Sheets("IgangvSpec").Range("R65536").End(xlUp).Row Data1 = ThisWorkbook.Sheets("IgangvSpec").Range("S5:T" & RW) For intI = 5 To UBound(Data1) If Data1(intI, 1) = "X" Then ThisWorkbook.Sheets("2008").Range("F" & Data1(intI,2)) = "ja" End If Next intI End Sub
Sub Spec_retur() Dim RW As Long, Data1 As Variant Dim intI As Integer
RW = ThisWorkbook.Sheets("IgangvSpec").Range("R65536").End(xlUp).Row Data1 = ThisWorkbook.Sheets("IgangvSpec").Range("S5:T" & RW) For intI = 1 To UBound(Data1) If Data1(intI, 1) = "X" Then ThisWorkbook.Sheets("2008").Range("F" & Data1(intI,2)) = "ja" End If Next intI End Sub
Sub Spec_retur() Dim RW As Long, Data1 As Variant Dim intI As Integer
RW = ThisWorkbook.Sheets("IgangvSpec").Range("S65536").End(xlUp).Row Data1 = ThisWorkbook.Sheets("IgangvSpec").Range("S5:T" & RW) For intI = 1 To UBound(Data1) If Data1(intI, 1) = "X" Then ThisWorkbook.Sheets("2008").Range("F" & Data1(intI,2)) = "ja" End If Next intI End Sub
Jeg skal ikke have point, for det jeg skrev, men det med at bruge Array og finde den sidste celle med data i, er et must, for at speede koden op. Se Bak's artikel her http://www.eksperten.dk/artikler/522
Kan ikke måle hvilken der er hurtigst, men begge er da vist en forbedring :-)
Sub Spec_Tilbage() Application.ScreenUpdating = False Set shspec = ThisWorkbook.Sheets("IgangvSpec") Set sh2008 = ThisWorkbook.Sheets("2008") rk = 4 x = Application.CountIf(shspec.Range("S5:S25000"), "X")
For t = 1 To x rk1 = shspec.Range("S" & rk & ":S25000").Find("X", LookIn:=xlValues).Row rk = rk1 sh2008.Cells(shspec.Cells(rk, "T"), "F") = "ja" Next
Mange tak for de forskellige inputs, ikke mindst forklaringen omkring arrays
Jeg har testet begge løsninger og de gør det faktisk lige hurtigt. Det tager dog stadig en del tid, når der kommer 10 - 20 poster der skal sættes til nej.
Jeg har sendt mit ark til excelent i håbet om at mit ark med de faktiske poster kan visualisere mit problem bedre end jeg har kunnet forklare.
Jeg har nemlig den opfattelse af at koden burde kunne gøre det i et snuptag, hvis bare jeg kunne forklare problemet helt korrekt.
ja, det viser sig jo så at begge jeres koder er lynhurtige. Grunden til at det tager rimelige lang tid er at jeg har nogle meget tunge formler som kører imens koden køres. Så snart at beregningen blive sat til MANUEL. Er alt som det skal være..... Tak for tippet Excelent :-)
Jeg beklager at jeg har lavet sådan en tanketorsk....
Så skal der bare uddeles en tak for hjælpen og points.
Og så lige et lille ting jeg er kommet til at tænke på efter kabbaks indlæg med arrays. Kan den første kode (se nedenfor) evt.kunne gøres hurtigere ved at inlæse i arrays?
Sub IgangvSpec_hent_åbne_poster() Application.ScreenUpdating = False Application.Calculation = xlManual Dim intI As Integer Dim intJ As Integer
intJ = 5 Do Until (ThisWorkbook.Sheets("IgangvSpec").Cells.Range("B" & intJ) = "") intJ = intJ + 1 Loop
For intI = 5 To 25000 If (ThisWorkbook.Sheets("2008").Cells.Range("B" & intI) = ThisWorkbook.Sheets("faktura").Range("faktura_kundenr") _ And ThisWorkbook.Sheets("2008").Cells.Range("F" & intI) <> "Ja") Then ThisWorkbook.Sheets("2008").Cells.Range("S" & intI) = intI ThisWorkbook.Sheets("2008").Cells.Range("A" & intI & ":T" & intI).Copy ThisWorkbook.Sheets("IgangvSpec").Range("A" & intJ) ThisWorkbook.Sheets("2008").Cells.Range("S" & intI) = intI ThisWorkbook.Sheets("IgangvSpec").Range("T" & intJ) = True intJ = intJ + 1 End If Next intI
Sheets("IgangvSpec").Range("igangv_nu") = Now Sheets("IgangvSpec").Range("igangv_kunde") = Sheets("faktura").Range("faktura_kundenr")
Range("a5").Select Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub
Set shspec = ThisWorkbook.Sheets("IgangvSpec") Set sh2008 = ThisWorkbook.Sheets("2008") Set shFak = ThisWorkbook.Sheets("faktura")
intJ = 5 Do Until (shspec.Cells.Range("B" & intJ) = "") intJ = intJ + 1 Loop
For intI = 5 To 25000 If sh2008.Cells.Range("B" & intI) = shFak.Range("faktura_kundenr") And sh2008.Cells.Range("F" & intI) <> "Ja" Then ThisWorkbook.Sheets("2008").Cells.Range("S" & intI) = intI sh2008.Range("T" & intI) = intI sh2008.Cells.Range("A" & intI & ":T" & intI).Copy shspec.Range("A" & intJ) shspec.Range("S" & intJ) = "X" intJ = intJ + 1 End If Next intI
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.
