Kaja100 Skrevet 21. juni 2017 Rapporter Del Skrevet 21. juni 2017 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
ExcelGuru Skrevet 21. juni 2017 Rapporter Del Skrevet 21. juni 2017 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
Anbefalte innlegg
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 kontoLogg inn
Har du allerede en konto? Logg inn her.
Logg inn nå