30. marts 2010 - 16:32Der er
11 kommentarer og 1 løsning
Filtrere data og dele ud af ID i kolonne A
Hej,
Jeg har lavet et regneark som skal udføre nogle bestemte beregninger i hvert sit ark.
Jeg har også lavet et indlæsningsark hvor min rådata er placeret. Nu har jeg brug for at kunne smide dataen ud i de forskellige ark afhængigt af et ID i kolonne A.
Indlæsningsark:
ID, Kundenummer, kontrakt 15 43242343, 0,4325
Hvis der står "15" skal den eksempelvis overføre rækken til ark 4.
Nogen som kan hjælpe med at lave en makro eller et script i VBA.
Teknologi, AI og forretning er i centrum på Computerworlds Cloud og AI Festival i København d. 18. og 19. september. Se hele programmet for den store konference om strategisk brug af Cloud og AI på: www.cloud-festival.dk
OBS: Første ark kaldes "Rådata" - herunder anbringes VBA-koden (højreklik på ark / Vis programkode) Aktiveres fra Excel: Alt+F8 - afspil makro "fordelingAfRådata"
Dim sidsteRække As Long, sidsteKolonne As Long, ræk As Long Dim idNr As Byte, arkNr As Byte, IdListe As Variant, ArkListe As Variant Public Sub fordelingAfRådata() sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row sidsteKolonne = ActiveCell.SpecialCells(xlLastCell).Column
IdListe = Array(15, 12, 14, 5) 'Id-nr ArkListe = Array(4, 3, 7, 8) 'Arknr, hvor ID-nr placeres - do index.
For ræk = 2 To sidsteRække idNr = Cells(ræk, 1) arkNr = findArkNr(idNr)
If arkNr > 0 Then ActiveSheet.Rows(ræk).Select Selection.Copy indsætPåArk arkNr Application.CutCopyMode = False ActiveWorkbook.Sheets("Rådata").Activate
Else MsgBox ("Id " & CStr(idNr) & " kunne ikke findes i liste") End If Next ræk End Sub Private Function findArkNr(idNr) Dim ix As Byte For ix = 0 To UBound(IdListe) If idNr = IdListe(ix) Then findArkNr = ArkListe(ix) Exit Function End If Next ix
findArkNr = 0 End Function Private Sub indsætPåArk(arkNr) Dim ræk ActiveWorkbook.Sheets("Ark" & CStr(arkNr)).Select For ræk = 2 To 65000 If ActiveSheet.Cells(ræk, 1) = "" Then ActiveSheet.Rows(CStr(ræk)).Select ActiveSheet.Paste Exit Sub End If Next ræk End Sub
Dim sidsteRække As Long, ræk As Long Dim idNr As Byte, arkNavn As String, IdListe As Variant, ArkListe As Variant Public Sub fordelingAfRådata() sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
IdListe = Array(15, 12, 14, 5) 'Id-nr ArkListe = Array("Erhverv", "Test", "Udland", "Potientielle") 'Arknavn, hvor ID-nr placeres - do index.
For ræk = 2 To sidsteRække idNr = Cells(ræk, 1) arkNavn = findArkNavn(idNr)
If arkNavn <> "" Then ActiveSheet.Rows(ræk).Select Selection.Copy indsætPåArk arkNavn Application.CutCopyMode = False ActiveWorkbook.Sheets("Rådata").Activate
Else MsgBox ("Id " & CStr(idNr) & " kunne ikke findes i liste") End If Next ræk End Sub Private Function findArkNavn(idNr) Dim ix As Byte For ix = 0 To UBound(IdListe) If idNr = IdListe(ix) Then findArkNavn = ArkListe(ix) Exit Function End If Next ix
findArkNavn = "" End Function Private Sub indsætPåArk(arkNavn) Dim ræk ActiveWorkbook.Sheets(arkNavn).Select For ræk = 2 To 65000 If ActiveSheet.Cells(ræk, 1) = "" Then ActiveSheet.Rows(CStr(ræk)).Select ActiveSheet.Paste Exit Sub End If Next ræk End Sub
Det var også den rettelse jeg selv havde lavet, men tak igen. Et sidste spørgsmål...? (hvis du vil have yderligere point så opretter jeg bare et spm. mere.)
Kan man få den til at fjerne rækkerne i rådata så man på den måde kan kontrollere at alle linjerne er blevet kopieret?
Dim sidsteRække As Long, ræk As Long Dim idNr As Byte, arkNavn As String, IdListe As Variant, ArkListe As Variant Public Sub fordelingAfRådata() sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
IdListe = Array(15, 12, 14, 5) 'Id-nr ArkListe = Array("Erhverv", "Test", "Udland", "Potientielle") 'Arknavn, hvor ID-nr placeres - do index.
For ræk = 2 To sidsteRække idNr = Cells(ræk, 1) If idNr > 0 Then arkNavn = findArkNavn(idNr)
If arkNavn <> "" Then ActiveSheet.Rows(ræk).Select Selection.Copy indsætPåArk arkNavn ActiveWorkbook.Sheets("Rådata").Activate
Selection.Delete ræk = ræk - 1 Application.CutCopyMode = False Else MsgBox ("Id " & CStr(idNr) & " kunne ikke findes i liste") End If End If Next ræk End Sub Private Function findArkNavn(idNr) Dim ix As Byte For ix = 0 To UBound(IdListe) If idNr = IdListe(ix) Then findArkNavn = ArkListe(ix) Exit Function End If Next ix
findArkNavn = "" End Function Private Sub indsætPåArk(arkNavn) Dim ræk ActiveWorkbook.Sheets(arkNavn).Select For ræk = 2 To 65000 If ActiveSheet.Cells(ræk, 1) = "" Then ActiveSheet.Rows(CStr(ræk)).Select ActiveSheet.Paste Exit Sub End If Next ræk End Sub
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.