[Løst] Makro i excel

[Kjuppapa]

Hei

 

Jeg driver og ordner med et excel ark der jeg gjerne skulle ha fått flyttet radere automatisk over til nytt ark.

vet man kan bruke makro til dette men dette er noe jeg har lite viten om. er det noen som kan hjelpe.

 

jeg kunne ha tenkt meg det at ner jeg skriver ja i kollonen motatt så flyttes den raden automatisk over i et et annet ark som heter Mottatte deler og raden i det første arket slettes derifra. 

 

jeg må ha det inn med tskje så ver tolmodig når dere svarer

 

Geir

 

   

[Harald Staff]

Hei Geir

 

Høyreklikk arkfanen Bestilte deler. Velg "View code" -eller "Vis kode" om det er på norsk.

 

Nå dukker et stort hvitt ark opp, en Modul på data'sk. Lim inn dette:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target(1).Column = 9 Then
If UCase(Target(1).Value) = "JA" Then
   Call KopierMeg(Target(1).Row)
End If
End If
End Sub


Private Sub KopierMeg(R As Long)
Dim RW As Long, C As Long
RW = Sheets("Mottatte deler").Cells(50000, 1).End(xlUp).Row + 1
For C = 1 To 15
Sheets("Mottatte deler").Cells(RW, C).Value = _
    Me.Cells(R, C).Value
Next
Me.Rows(R).Delete
End Sub

Så lukker du vinduet og går tilbake til Excel, og så skal det virke.

Dette avhenger at Ja skrives i I-kolonnen (kolonnenummer 9) og at destinasjonsarket heter "Mottatte deler". Hvis du endrer dette så må du også endre i denne koden. Men det finner du ut av om den tid kommer

 

Edit: PS du må lagre filen som Makroaktivert arbeidsbok filtype xlsm, eller gammelt format xls, ellers forsvinner programmeringskoden.

 

Beste hilsen Harald

Endret 27. oktober 2017 av Harald Staff

[Kjuppapa]

Hei Geir

 

Høyreklikk arkfanen Bestilte deler. Velg "View code" -eller "Vis kode" om det er på norsk.

 

Nå dukker et stort hvitt ark opp, en Modul på data'sk. Lim inn dette:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target(1).Column = 9 Then
If UCase(Target(1).Value) = "JA" Then
   Call KopierMeg(Target(1).Row)
End If
End If
End Sub


Private Sub KopierMeg(R As Long)
Dim RW As Long, C As Long
RW = Sheets("Mottatte deler").Cells(50000, 1).End(xlUp).Row + 1
For C = 1 To 15
Sheets("Mottatte deler").Cells(RW, C).Value = _
    Me.Cells(R, C).Value
Next
Me.Rows(R).Delete
End Sub

Så lukker du vinduet og går tilbake til Excel, og så skal det virke.

Dette avhenger at Ja skrives i I-kolonnen (kolonnenummer 9) og at destinasjonsarket heter "Mottatte deler". Hvis du endrer dette så må du også endre i denne koden. Men det finner du ut av om den tid kommer

 

Edit: PS du må lagre filen som Makroaktivert arbeidsbok filtype xlsm, eller gammelt format xls, ellers forsvinner programmeringskoden.

 

Beste hilsen Harald

hm det fikk jeg ikke til du gidt ble ikke noen endringer med det

[Kjuppapa]

Fant ut av det var bare en skrivefeil i koden din. men hvordan kan jeg gjøre det når jeg vil at den skal flyttes ved at jeg skriver inn en sporingsnr til posten. den er jo forskjellig fra pakke til pakke.

 

ser også at etter de er flyttet så legger de seg rart slik vist på bilde

  

 

 

Hei Geir

 

Høyreklikk arkfanen Bestilte deler. Velg "View code" -eller "Vis kode" om det er på norsk.

 

Nå dukker et stort hvitt ark opp, en Modul på data'sk. Lim inn dette:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target(1).Column = 9 Then
If UCase(Target(1).Value) = "JA" Then
   Call KopierMeg(Target(1).Row)
End If
End If
End Sub


Private Sub KopierMeg(R As Long)
Dim RW As Long, C As Long
RW = Sheets("Mottatte deler").Cells(50000, 1).End(xlUp).Row + 1
For C = 1 To 15
Sheets("Mottatte deler").Cells(RW, C).Value = _
    Me.Cells(R, C).Value
Next
Me.Rows(R).Delete
End Sub

Så lukker du vinduet og går tilbake til Excel, og så skal det virke.

Dette avhenger at Ja skrives i I-kolonnen (kolonnenummer 9) og at destinasjonsarket heter "Mottatte deler". Hvis du endrer dette så må du også endre i denne koden. Men det finner du ut av om den tid kommer

 

Edit: PS du må lagre filen som Makroaktivert arbeidsbok filtype xlsm, eller gammelt format xls, ellers forsvinner programmeringskoden.

 

Beste hilsen Harald

hm det fikk jeg ikke til du gidt ble ikke noen endringer med det

 

 

Endret 27. oktober 2017 av Kjuppapa

[Frank Drebin]

 

Fant ut av det var bare en skrivefeil i koden din.

Hva var skrivefeilen? Fungerte helt fint her i hvert fall, uten noen endringer i Haralds kode.

[Kjuppapa]

RW = Sheets("Mottatte deler").Cells(50000, 1).End(xlUp).Row + 1

måtte endre denne til bestilte deler så funket det

 

 

 

Fant ut av det var bare en skrivefeil i koden din.

Hva var skrivefeilen? Fungerte helt fint her i hvert fall, uten noen endringer i Haralds kode.

 

[Kjuppapa]

da har jeg fått til flytting men noen som har tips til hva jeg kan gjøre for at de legger seg fra topp og nedover for nå blir de jo lagt hulter til bulter et flytting. skulle jo ha begynt på rad 4 

[Harald Staff]

Hei igjen Geir

 

Linjen du har "rettet" fant første ledige rad under det siste som står i A-kolonnen i arket Mottatte deler. Rettelsen din lager ikke bare hulter til bulter, du risikerer å overskrive eksisterende linjer. Rett tilbake.

 

Problemet er antakelig at du har noe skrot langt nede utenfor syne i kolonne A i det arket. Det kan være noe så uskyldig en celle som inneholder bare et usynlig mellomrom. Radene du ikke fant står nok under det. Du finner slutten av et ark med Ctrl End, og du leter opp og ned kolonner med End og så pil opp eller pil ned. Slett radene med skrot så virker koden.

 

Beste hilsen Harald

Endret 28. oktober 2017 av Harald Staff

[Kjuppapa]

tøft no ble alt ok. begynte med et helt nytt regneark bare for å være sikker. har nå sittet og testet og funker kjempe. takk for svar

[Kjuppapa]

dette funket en stund men når jeg nå flyttet over med orginalkoden du sendte så legger denalt på 1 rad og sletter det som har stått

 

Hei igjen Geir

 

Linjen du har "rettet" fant første ledige rad under det siste som står i A-kolonnen i arket Mottatte deler. Rettelsen din lager ikke bare hulter til bulter, du risikerer å overskrive eksisterende linjer. Rett tilbake.

 

Problemet er antakelig at du har noe skrot langt nede utenfor syne i kolonne A i det arket. Det kan være noe så uskyldig en celle som inneholder bare et usynlig mellomrom. Radene du ikke fant står nok under det. Du finner slutten av et ark med Ctrl End, og du leter opp og ned kolonner med End og så pil opp eller pil ned. Slett radene med skrot så virker koden.

 

Beste hilsen Harald

[Kjuppapa]

nå ser det ut som at det funker jeg må vist legge noe inn i første celle på hver rad skal det funke og da kommer det an på om han blir glad hvis det står samme dato 

 

 

dette funket en stund men når jeg nå flyttet over med orginalkoden du sendte så legger denalt på 1 rad og sletter det som har stått

 

Hei igjen Geir

 

Linjen du har "rettet" fant første ledige rad under det siste som står i A-kolonnen i arket Mottatte deler. Rettelsen din lager ikke bare hulter til bulter, du risikerer å overskrive eksisterende linjer. Rett tilbake.

 

Problemet er antakelig at du har noe skrot langt nede utenfor syne i kolonne A i det arket. Det kan være noe så uskyldig en celle som inneholder bare et usynlig mellomrom. Radene du ikke fant står nok under det. Du finner slutten av et ark med Ctrl End, og du leter opp og ned kolonner med End og så pil opp eller pil ned. Slett radene med skrot så virker koden.

 

Beste hilsen Harald

 

[Harald Staff]

Hei igjen

 

Jeg ser du har satt denne til Løst. Men for arkivets skyld, her er en modifisert KopierMeg som ikke er avhengig av en bestemt utfylt kolonne:

Private Sub KopierMeg(R As Long)
Dim RW As Long, C As Long
Dim RL As Long
For C = 1 To Sheets("Mottatte deler").UsedRange.Columns.Count
    RL = Sheets("Mottatte deler").Cells(50000, C).End(xlUp).Row + 1
    If RL > RW Then RW = RL
Next
For C = 1 To 15
Sheets("Mottatte deler").Cells(RW, C).Value = _
    Me.Cells(R, C).Value
Next
Me.Rows(R).Delete
End Sub

Beste hilsen Harald

[Kjuppapa]

Good. Men den første funker utmerket når jeg fant det ut. Er bare nå i starten jeg ikke har noe stående i første kollone så det løste jeg bare med å skrive en x der.