Makro til at flytte data fra 1 ark til et andet...
Hej jeg sidder og skal lave et excel ark over en venteliste.
Ventelisten er inddelt i 6 ark, som passer sammen 2 og 2.
Jeg vil gerne have at hvis jeg trykker på en command knap ud for hver linje i ark1 så flytter den linjen til næste ledige linje i ark 2. Samtidig skal den så rykke alle de tilbageværende rækker i ark1 op så der ikke opstår huller.
Jeg har forsøgt med forskellige makroer men kan ikke helt få det til at fungere.
Problemet med den er at den overskriver de tidligere data bl.a. den aller øverste linje, hvor beskrivelserne står i.
Jeg har også forsøgt med: Sub FLYT() ' ' FLYT Makro
Dim rngOrigin As Range, rngDest As Range Dim i, j As Integer
i = 1: j = 1 Set rngOrigin = Sheets("140").Range("H3") Set rngDest = Sheets("Behandlet 140").Range("A1").Offset(Application.WorksheetFunction.CountA(Sheets("Behandlet 140").Range("A:A")))
Do While rngOrigin.Offset(i, 0).Value <> "" If rngOrigin.Offset(i, 0).Value = "OVERSKREDET" Then rngOrigin.Offset(i, 0).EntireRow.Copy Sheets("Behandlet 140").Activate rngDest.Offset(j, 0).Select ActiveSheet.Paste Sheets("140").Activate rngOrigin.Offset(i, 0).EntireRow.Delete xlShiftUp j = j + 1 i = i - 1 End If i = i + 1 Loop Application.CutCopyMode = False End Sub
Men den flytter bare samtlige, som er overskredet til det nye ark, i stedet for blot at flytte en række.
Alt i alt skal ventelisten fungere sådan at trykker jeg på en knap bliver den person knappen tilhører flyttet til et andet ark og de andre flyttet op.
Skal der være 1 knap pr. linie/række ? Alternativet kunne være 1 knap på arket, som flytter rækken med den aktive celle ... hvilket vil betyde, at du skal markere den række der ønskes flyttet.
Her er et forslag til en makro der kopierer den række du står i på Ark1 og indsætter den på første ledige række på Ark 2 - og derefter sletter rækken på Ark 1. Er det noget i den retning du skal bruge?
Sub flytdata()
Dim targetRow As Long
' finder første tomme række i ark2 targetRow = Worksheets("Ark2").Range("A65536").End(xlUp).Row + 1
' kopierer aktiv række Rows(ActiveCell.Row & ":" & ActiveCell.Row).Copy
' vælger kopiarket og den første ledige række og indsætter Worksheets("Ark2").Select Rows(targetRow & ":" & targetRow).Select ActiveSheet.Paste
' tilbage til originalarket Worksheets("Ark1").Select
' flytter cursor en række op ActiveCell.Offset(-1, 0).Select 'sletter Rows(ActiveCell.Row + 1 & ":" & ActiveCell.Row + 1).Delete
Her er et alternativ, som tjekker om den aktive celle på Sheet1 er tom ? ... samt kopiere til første række på Sheet2 i stedet for anden række, første gang der bliver kopieret!
Private Sub FlytAktivRække() Dim r As Integer 'variabel til rækkenummer Dim t As Range 'område variabel til den række der kopieres
'slå skærmopdateringen fra Application.ScreenUpdating = False
'tjek om der er en værdi at kopiere ? If ActiveCell.Value = "" Then
MsgBox "Der er ingen værdi at kopiere", vbInformation Exit Sub
Else
'set t lig med hele den aktive række på arket Sheet1 Set t = ActiveCell.EntireRow
'kopier rækken med den aktive celle t.Copy
'gør arket Sheet2 til det aktive ark Sheet2.Activate
'hvis celle A1 på Sheet 2 er tom ... hvilket den er første gang der kopieres data til arket If Sheet2.Range("A1") = "" Then
'indsæt det kopierede, startende fra den aktive celle ActiveCell.PasteSpecial xlPasteAll
'fjern kopimarkeringen fra arket Sheet1 Application.CutCopyMode = False
'gør arket Sheet1 til det aktive ark Sheet1.Activate
'vælg celle A1 på arket Sheet1 Range("A1").Select
Else
'tildel variablen r, rækkenummeret på sidste række i kolonne A på Sheet2, som indeholder data r = ActiveSheet.Range("A65536").End(xlUp).Row
'vælg celle A i rækken efter sidste række indeholdende data ActiveSheet.Range("A" & r + 1).Select
'indsæt det kopierede, startende fra den aktive celle ActiveCell.PasteSpecial xlPasteAll
'fjern kopimarkeringen fra arket Sheet1 Application.CutCopyMode = False
'gør arket "Sheet1" til det aktive ark Sheet1.Activate
'vælg celle A1 på Sheet1 Range("A1").Select
End If
'slå applikationshændelser fra Application.EnableEvents = False
'slet hele den kopierede række på arket Sheet1 t.Delete
'slå applikationshændelser til igen Application.EnableEvents = True
End If
'slå skærmopdateringer til igen Application.ScreenUpdating = True
Låsning/beskyttelse af celler i Excel 2003 Som udgangspunkt er alle celler låste, men selve låsningen træder først i kraft, når arket beskyttes.
- Marker de celler du ønsker at taste i - Højreklik i det markedere område og vælg Format Cells - Vælg sidste faneblad og fjern fluebenet ud for Locked. - Klik OK
- Under Tools på menu linien vælger du Protection > Protect Sheet - Indtast dit password ... 2 gange og afslut med OK.
Nu burde di ark være låst/beskytte bortset fra de celler du har fravalgt.
I mit kode eksempel kan du så tilføje 2 linier umiddelbart efter at hændelserne er slået fra. De markerede herunder er linierne ... og mit password er "a":
'slå applikationshændelser fra Application.EnableEvents = False
'ubeskyt arket med password "a" Sheet1.Unprotect ("a")
'slet hele den kopierede række på arket Sheet1 t.Delete
'beskyt arket med password "a" Sheet1.Protect ("a")
Lalocin jeg kan ikke helt få din kode til at virke.... selvom jeg omdøber sheet1 til 140 og sheet2 til Behandlet 140, sådan som de hedder på mit ark...
Jeg vil have at det kun er bestemte rækker/celler man kan skrive i og resten skal ikke kunne røres. Den skulle gerne kunne gives til andre som ikke kender særlig meget til excel
Her er en makro der kan behandle dit Ark1 på følgende måde:
Låser først arket op hvis det er låst i forvejen Fjerner al tidligere skrivebeskyttelse af celler i hele arket Skrivebeskytter celler i dine rækker med tata Låser artket igen.
Sub skrivebeskytoglås()
Worksheets("Ark1").Select
Dim targetRow As Long
' fjerner arkbeskyttelsen ActiveSheet.Unprotect
' finder sidste datarække targetRow = Worksheets("Ark1").Range("A65536").End(xlUp).Row
' fjerner cellebskyttelse på alle celler Cells.Locked = False Rows(1 & ":" & targetRow).Locked = True
' låser arket igen ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
