Koden blev følgende:
Rem version 1
Rem =========
Dim ark1 As Worksheet
Dim arkIndtast As Worksheet
Dim ark2 As Worksheet
Dim invNr, tekst, By, Etage, foranTekstArk1
Sub Opdatering() '<--- Knappen på arket Indtast aktiveret den SUB
definerArk
Application.ScreenUpdating = False
ark1.Activate
hentIndtastedeData
findByEtagePåArk1
Application.ScreenUpdating = True
MsgBox ("Opdatering udført")
End Sub
Private Sub definerArk()
With ActiveWorkbook
Set ark1 = .Sheets("Ark1")
Set arkIndtast = .Sheets("Indtast")
Set ark2 = .Sheets("Ark2")
End With
End Sub
Private Sub hentIndtastedeData()
invNr = Range("B3").Value
tekst = Range("C3").Value
By = Range("D3").Value
Etage = CStr(Range("E3").Value)
End Sub
Private Sub findByEtagePåArk1()
Const startRæk = 6
Dim slutRæk
ark1.Activate
Rem traverser på Ark1
slutRæk = ActiveCell.SpecialCells(xlLastCell).Row
For r = startRæk To slutRæk
If LCase(Trim(ark1.Cells(r, 2))) = LCase(By) Then
findEtageArk1 r, slutRæk
Exit Sub
End If
Next r
MsgBox (By & " er ikke fundet på Ark1")
End Sub
Private Sub findEtageArk1(startRæk, slutRæk)
Dim tekst, fedSkrift
For r = startRæk + 1 To slutRæk
tekst = ark1.Cells(r, 3)
fedSkrift = ark1.Cells(r, 3).Font.Bold
If InStr(tekst, Etage) = 1 And fedSkrift = True Then
findIndsættelsesRækkeArk1 r + 1, slutRæk
Exit Sub
End If
Next r
MsgBox (Etage & ". etage ikke fundet på Ark1")
End Sub
Private Sub findIndsættelsesRækkeArk1(startRække, slutRække)
Dim tekst, fedSkrift
Rem Skal finde Ny etage eller slutningen af Tabellen
For r = startRække To slutRække
tekst = ark1.Cells(r, 3)
fedSkrift = ark1.Cells(r, 3).Font.Bold
If fedSkrift = True Then
Rem Næste etage er fundet
IndsætNyrækkeArk1 r
Exit Sub
Else
Rem Test om slutningen af tabel er nået
If testKolonneBLtomArk1(r) = True Then
IndsætNyrækkeArk1 r
Exit Sub
End If
End If
Next r
MsgBox ("Ny række ikke fundet på Ark1")
End Sub
Private Function testKolonneBLtomArk1(række)
testKolonneBLtomArk1 = True
For Each cc In ark1.Range("B" & CStr(række) & ":L" & CStr(række)).Cells
If cc.Value <> "" Then
testKolonneBLtomArk1 = False
Exit Function
End If
Next
End Function
Private Sub IndsætNyrækkeArk1(foranRække)
foranTekstArk1 = ark1.Cells(foranRække, 3)
Rem Indsæt ny række på Ark2 inden af hensyn til formler ********
findByEtagePåArk2
Rem Ark1
ark1.Activate
ark1.Rows(CStr(foranRække) & ":" & CStr(foranRække)).Select
Selection.Insert Shift:=xlDown
kopierFormlerFormat foranRække - 1, foranRække
Rem kopier formler fra række ovenfor
Rem Indsæt Inv.Nr & tekst i den nye række
ark1.Cells(foranRække, 2) = invNr
ark1.Cells(foranRække, 3) = tekst
End Sub
Private Sub kopierFormlerFormat(fraRæk, tilRæk)
Rem Overfør formler fra kolonnerne B - L
udførKopiering "B", fraRæk, tilRæk
udførKopiering "C", fraRæk, tilRæk
udførKopiering "D", fraRæk, tilRæk
udførKopiering "E", fraRæk, tilRæk
udførKopiering "F", fraRæk, tilRæk
udførKopiering "G", fraRæk, tilRæk
udførKopiering "H", fraRæk, tilRæk
udførKopiering "I", fraRæk, tilRæk
udførKopiering "J", fraRæk, tilRæk
udførKopiering "K", fraRæk, tilRæk
udførKopiering "L", fraRæk, tilRæk
End Sub
Private Sub udførKopiering(kolonne, fraRæk, tilRæk)
Dim bagFarve
ark1.Activate
With ark1
Rem Kopier formel, hvis den findes i rækken ovenfor
If .Range(kolonne & CStr(fraRæk)).HasFormula = True Then
.Range(kolonne & CStr(fraRæk) & ":" & kolonne & CStr(tilRæk)).FillDown
End If
Rem Kopier formatering fra rækken ovenfor
.Cells(fraRæk, kolonne).Select
bagFarve = Selection.Interior.ColorIndex
Selection.Copy
.Cells(tilRæk, kolonne).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Interior.ColorIndex = bagFarve
End With
End Sub
Rem ************** ARK2 ********************
Private Sub findByEtagePåArk2()
Const startRæk = 4
Dim slutRæk
ark2.Activate
Rem traverser på Ark2
slutRæk = ActiveCell.SpecialCells(xlLastCell).Row
For r = startRæk To slutRæk
If InStr(LCase(Trim(ark2.Cells(r, 1))), LCase(By)) > 0 Then
findEtageArk2 r, slutRæk
Exit Sub
End If
Next r
MsgBox (By & " er ikke fundet på Ark2")
End Sub
Private Sub findEtageArk2(startRæk, slutRæk)
Dim tekst, fedSkrift
For r = startRæk + 1 To slutRæk
tekst = ark2.Cells(r, 2)
fedSkrift = ark2.Cells(r, 2).Font.Bold
If InStr(tekst, Etage) = 1 And fedSkrift = True Then
findIndsættelsesRækkeArk2 r + 1, slutRæk
Exit Sub
End If
Next r
MsgBox (Etage & ". etage ikke fundet på Ark2")
End Sub
Private Sub findIndsættelsesRækkeArk2(startRække, slutRække)
Dim tekst, fedSkrift
Rem Skal finde Ny etage eller slutningen af Tabellen
For r = startRække To slutRække
tekst = ark2.Cells(r, 2)
If tekst = foranTekstArk1 Then
Rem Næste etage er fundet
IndsætNyrækkeArk2 r
Exit Sub
Else
Rem Test om slutningen af tabel er nået
If testKolonneBLtomArk2(r) = True Then
IndsætNyrækkeArk2 r
End If
End If
Next r
MsgBox ("Ny række ikke fundet på Ark2")
End Sub
Private Function testKolonneBLtomArk2(række)
testKolonneBLtomArk2 = True
For Each cc In ark2.Range("A" & CStr(række) & ":C" & CStr(række)).Cells
If cc.Value <> "" Then
testKolonneBLtomArk2 = False
Exit Function
End If
Next
End Function
Private Sub IndsætNyrækkeArk2(foranRække)
ark2.Rows(CStr(foranRække) & ":" & CStr(foranRække)).Select
Selection.Insert Shift:=xlDown
Rem Indsæt Inv.Nr & tekst i den nye række
ark2.Cells(foranRække, 1) = invNr
ark2.Cells(foranRække, 2) = tekst
End Sub
