Søgning gennem VBA
Nedenstående VBA søger efter værdien "Soeg_ID" i det i andre ark.Min udfordring er, at hvis "Soeg_ID" forekommer mere end en gang i et ark, så kopieres der kun en af rækkerne.
Hvorledes kan VBA'en tilrettes så alle forekomster af "Soeg_ID" kommer med fra hvert ark?
Sub FindLokalitet()
Dim ID As String, Status As String, SheetNo As Integer
Dim Sh, Lastrow As Integer, N As Integer
Dim FirstSheet(7) As Integer, LastSheet(7) As Integer
Dim AntalIKategori As Integer, Kategori As Integer
Dim StartRow(7) As Integer, SoegArk As String
Const Firstrow = 6
Application.ScreenUpdating = False
Call RydLister
SoegArk = ActiveSheet.Name
ID = ActiveWorkbook.Names("Soeg_ID").RefersToRange
'Første kategori historik og indledende
FirstSheet(1) = 7
LastSheet(1) = 8
StartRow(1) = 9
'Anden kategori videregående GV
FirstSheet(2) = 9
LastSheet(2) = 9
StartRow(2) = 14
'Tredje kategori afværge GV
FirstSheet(3) = 12
LastSheet(3) = 12
StartRow(3) = 14
'Fjerde kategori videregående AA
FirstSheet(4) = 10
LastSheet(4) = 11
StartRow(4) = 19
'Femte kategori afværge AA
FirstSheet(5) = 13
LastSheet(5) = 14
StartRow(5) = 19
'Sjette kategori uden OI
FirstSheet(6) = 15
LastSheet(6) = 15
StartRow(6) = 24
'Syvende kategori igangsatte
FirstSheet(7) = 16
LastSheet(7) = 16
StartRow(7) = 29
For Kategori = 1 To 7
AntalIKategori = 0
For SheetNo = FirstSheet(Kategori) To LastSheet(Kategori)
With Sheets(SheetNo)
Lastrow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Status = .Name
For N = Firstrow To Lastrow
If .Cells(N, 1) = ID Then
AntalIKategori = AntalIKategori + 1
Sheets(SoegArk).Cells(StartRow(Kategori) + AntalIKategori - 1, 2).Value = Status
.Range(.Cells(N, 1), .Cells(N, 12)).Copy
Sheets(SoegArk).Cells(StartRow(Kategori) + AntalIKategori - 1, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Exit For
End If
Next N
End With 'SheetNo
Next SheetNo
Next Kategori
Range("C6").Select
Application.ScreenUpdating = True
End Sub
