Sub FindFirma()
Dim Firma As String, Vgrp As String
Dim Stext As Range 'SøkeText
Dim StextRes As String
Dim Celle As Integer, antallCeller As Integer
Dim Line, Linegrp As Integer

'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Line = 2
Linegrp = 2

antallCeller = Range("g2:g2000").CurrentRegion.Rows.Count - 1
While Sheets("Grupper").Cells(Linegrp, 1) <> ""
    If Sheets("Grupper").Cells(Linegrp, 1) <> "" Then
        Firma = Sheets("Grupper").Cells(Linegrp, 1)
        Vgrp = Sheets("Grupper").Cells(Linegrp, 2)
    End If

    With Sheet1.Range("g2:g2000")
        Set Stext = .Find(UCase(Firma))
        If Not Stext Is Nothing Then
            StextRes = Stext.Value
            For Celle = 1 To antallCeller
                Stext.Offset(0, 3).Value = Vgrp
                Set Stext = .FindNext(Stext)
            Next Celle
        End If
    
    End With

        Linegrp = Linegrp + 1
    Wend
    Set Stext = Nothing

'Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
ActiveWorkbook.Save

End Sub