Gå til innhold

Flytte hele rader basert på verdi i enkeltceller i excel - makro


Anbefalte innlegg

Hei!

 

Problemstillingen: jeg trenger å sette opp en automatisk kopiering av rader fra ett ark til et annet, gitt en betingelse, og vet ikke hvordan jeg skal sette opp makroen for dette.

 

Følgende ligger i ark2. Arket er navngitt "Nåsituasjon"

A1: Ansvarsnavn B1: Foreslått C1: Etternavn D1: Fornavn

 

Det er informasjon i rad 2 til rad 346.

 

Et eksempel

                   A               B                 C             D

Rad 1 Ansvarsnavn Foreslått   Etternavn Fornavn

Rad 2 Økonomi       Regnskap Petter     Hansen

 

Det jeg da ønsker er å sette opp en automatikk i at dersom det står "Regnskap" i kolonne B, skal raden med kolonnene B-D kopieres over i arket som jeg har kalt "Regnskap".

 

Jeg har ca 22 ark til (og 22 ulike titler under "Foreslått") så ideelt sett ønsker jeg å bruke samme makro, men det er jeg usikker på om går an? Er i så fall ikke imot å bruke samme kode flere ganger og kun endre betingelsen for kopiering.

 

Håper noen kan hjelpe meg! :)

 

Kaja

 

Lenke til kommentar
Videoannonse
Annonse

Morsom oppgave:)

Hvis du kjører makroen Flytt, flyttes alle linjene til respektive regneark. Hvis TIL-arket ikke finnes, blir det opprettet.

Du må ha med deg alle tre makroene:

 

Sub Flytt()
 Dim x As Long
 Dim Linje As Long
 Dim FaneNavn As String
 
 Dim FRA As Worksheet
 Dim TIL As Worksheet
 
 Set FRA = Sheets("Nåsituasjon")
 
 With FRA
  x = 2: While .Cells(x, 2) <> ""
   FaneNavn = .Cells(x, 2)
   
  
   'Sørg for at fanen finnes
   If FinnesFane(FaneNavn) = False Then
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = FaneNavn
   End If
    
   'Nå vet vil at TIL-fanen finnes
    Set TIL = Sheets(FaneNavn)
    
   'Finn neste ledige linje i fanen som linjen skal til
   
   Linje = Ledig(TIL)
   
   With TIL
    y = 2: While y <= 4
     .Cells(Linje, y - 1) = FRA.Cells(x, y)
    y = y + 1: Wend
   End With
   
   x = x + 1: Wend
 End With
 
End Sub
 
Function Ledig(SH As Worksheet) As Long
 Dim x As Long
 With SH
  x = 2: While .Cells(x, 1) <> ""
  x = x + 1: Wend
  Ledig = x
  
 End With
End Function
 
Function FinnesFane(FaneNavn As String) As Boolean
 
 On Error GoTo feil
 
 With Sheets(FaneNavn)
  FinnesFane = True
  Exit Function
 End With
 
feil:
 FinnesFane = False
 
End Function
Lenke til kommentar

Opprett en konto eller logg inn for å kommentere

Du må være et medlem for å kunne skrive en kommentar

Opprett konto

Det er enkelt å melde seg inn for å starte en ny konto!

Start en konto

Logg inn

Har du allerede en konto? Logg inn her.

Logg inn nå
×
×
  • Opprett ny...