flytning af data

Forudsætter du har overskrifter i alle ark i række 1
sum ark er Ark1 ellers ret i anden linie

Sub Total()
Set sh1 = Sheets("Ark1")

For Each sh In ActiveWorkbook.Sheets
If sh.Name <> sh1.Name Then
sh.Activate
For t = 2 To sh.Cells(65000, 1).End(xlUp).Row
If Application.CountIf(sh1.Range("A2:A20000"), Cells(t, 1)) < 1 Then
sh1.Cells(sh1.Cells(65500, 1).End(xlUp).Row + 1, 1) = Cells(t, 1)
sh1.Cells(sh1.Cells(65500, 2).End(xlUp).Row + 1, 2) = Cells(t, 3)
Else
x = sh1.Range("A1:A20000").Find(Cells(t, 1), LookIn:=xlValues).Address
sh1.Range(x).Offset(0, 1) = sh1.Range(x).Offset(0, 1) + Cells(t, 3)
End If
Next
End If
Next

End Sub

hej excelent

nu er jeg langt fra den skarpeste til excel, men jeg formoder at det skal kopieres ind i VBA. Det har jeg gjort, jeg har i ark 2 (dansk excel, hvis det har betydning) skrevet
abc  def  ghi
100  200  400

men det sker der egentlig ikke det store ved. Hvad er det jeg ikke forstår

prøv mit test ark

http://pmexcelent.dk/Total.xls

kanon service :-) havde faktisk lige fået det til at virke her også

umiddelbart virker det ikke som om dit testark regner rigtigt sagsnummer 1000 giver da kun 5 timer og ikke 41

det kommer sørme an på hvor mange gange jeg har kørt makro :-)

d.v.s ark1 bliver ikke nulstillet ved kørsel som den er nu
skal den det ?

ja, den skal vise det faktiske billede og ikke tælle sammen.
Vi skal registrere antal timer brugt på en sag så den må ikke lægge mere sammen end det der står

i øvrigt skal jeg køre macroen kan den automatiseres så den selv mærker hvis der er en ændring?

hvordan kommer der data i arkene ?

de tastes manuelt, hvis det er det du mener

ok finder en løsning
imens kan du indsætte denne som linie 3
sh1.Range(Range("A2"), ActiveCell.SpecialCells(xlLastCell)).ClearContents

det var den nu ikke særlig glad for :-S

nej det opdagede jeg også lige, du får lige den reviderede
kode, skift ud med den gamle

Sub Total()

Application.ScreenUpdating = False
AktuelArk = ActiveSheet.Name: AktuelCelle = ActiveCell.Address
Set sh1 = Sheets("Ark1"): sh1.Activate
sh1.Range(Range("A2"), ActiveCell.SpecialCells(xlLastCell)).ClearContents
For Each sh In ActiveWorkbook.Sheets
If sh.Name <> sh1.Name Then
sh.Activate
For t = 2 To sh.Cells(65000, 1).End(xlUp).Row
If Application.CountIf(sh1.Range("A2:A20000"), Cells(t, 1)) < 1 Then
sh1.Cells(sh1.Cells(65500, 1).End(xlUp).Row + 1, 1) = Cells(t, 1)
sh1.Cells(sh1.Cells(65500, 2).End(xlUp).Row + 1, 2) = Cells(t, 3)
Else
x = sh1.Range("A1:A20000").Find(Cells(t, 1), LookIn:=xlValues).Address
sh1.Range(x).Offset(0, 1) = sh1.Range(x).Offset(0, 1) + Cells(t, 3)
End If
Next
End If
Next
Sheets(AktuelArk).Select: Range(AktuelCelle).Select
Application.ScreenUpdating = True

End Sub

kanon så langt så godt, men kan den så gøre det automatisk

Der er flere måder at få den til at køre automatisk
vi prøver lige med ændring i kolonne C i arkene
d.v.s. hver gang du indtaster en tid i C opdateres
Hvis du har mange ark og mange data, bliver det nok for
tungt at arbejde med (hastighed),- så prøver vi en anden

indsæt følgende kode i alle arks kodemodul - dog ikke Ark1

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C1:C2000")) Is Nothing Then Exit Sub
Call Total
End Sub

Arkenes kodemodul finder du således :
Højreklik på arkfane, vælg Vis Programkode, indsæt kode der

giver compile error

i hvilken linie ?

Private Sub Worksheet_Change(ByVal Target As Range)
er gul jeg formoder det er der fejlen er

har oploadet opdatering, klik link og hent den igen

Dit virker ser det ud til, det er mere end hvad mit gøt, men det er fint nok til mig så  kan jeg komme videre.
Tak for din venlige indsats, læg venligst et svar og se evt denne http://www.eksperten.dk/spm/808383 ;-)

ok ellers siger du bare til

der kommer med garanti mere men jeg tager det i bidder, tak igen

jeg kan ikke få det til at virke i det nye ark, kan du overtales til en lille omskrivning.

arkene hedder "Total" "Uge1" "Uge2"....

Data hentes fra sagsnummer G7 og ned, timer fra E7 og ned, afleveres i d og e6 og ned
pft

selfølgeli
skal lige tænke over hvad der kan være problemet
vender tilbage

ok prøv denne
(forudsætter du har overskrift i Total D5,E5 og i arkene E6,F6,G6):

Sub Total()

Application.ScreenUpdating = False ' Undgå at skærm flimrer når der skiftes ark m.v
AktuelArk = ActiveSheet.Name: AktuelCelle = ActiveCell.Address ' Husker aktuel ark og celle
Set sh1 = Sheets("Total"): sh1.Activate 'sh1 sættes=Ark1, er lettere at skrive flere gange : sh1 aktiveres
sh1.Range(Range("D6"), ActiveCell.SpecialCells(xlLastCell)).ClearContents ' Værdier i Ark1 slettes
For Each sh In ActiveWorkbook.Sheets ' Ark løkke starter
If sh.Name <> sh1.Name Then ' Sikrer at Ark1 ikke testes
sh.Activate ' Arkene aktiveres efter tur
For t = 7 To sh.Cells(65000, "G").End(xlUp).Row ' Finder nederste række med værdi i kolonne D
If Application.CountIf(sh1.Range("D6:D20000"), Cells(t, "G")) < 1 Then 'Test om aktuel sagsnr. findes i Total
sh1.Cells(sh1.Cells(65500, "D").End(xlUp).Row + 1, "D") = Cells(t, "G") 'Skriver sagsnr i Total i næste tomme celle
sh1.Cells(sh1.Cells(65500, "E").End(xlUp).Row + 1, "E") = Cells(t, "E") 'Skriver timer i Total i næste tomme celle
Else ' Aktuel sagsnummer fantes allerede i Ark1
x = sh1.Range("D6:D20000").Find(Cells(t, "G"), LookIn:=xlValues).Address 'Finder cellen i Total hvor sagsnr er
sh1.Range(x).Offset(0, 1) = sh1.Range(x).Offset(0, 1) + Cells(t, "E") ' Timer adderes til aktuel sagsnr
End If
Next
End If
Next
Sheets(AktuelArk).Select: Range(AktuelCelle).Select 'Oprindelig Ark og celle gøres aktiv igen
Application.ScreenUpdating = True ' Skærmopdatering sættes til igen

End Sub

----------------
og i alle ark skal den se således ud :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G7:G2000")) Is Nothing Then Exit Sub
Call Total
End Sub

he he problemet er mig

Det så rigtig fint ud, der er dog to uforudsete ting

jeg har værdien 0 (nul) i tomme e felter i uge arkene, kan vi nøjes med kun at flytte data hvis der er et sagsnummer. Det løser også mit problem nummer to, nemlig sammenlægningen af timerne nederst i e, de flyttes nemlig også. Men som sagt ellers så det rigtig godt ud, takker. Jeg kan lave et nyt spm. med p hvis du ønsker

Der opdateres kun hvis du indtaster noget i området G7:G2000
Vi kan godt checke om det er et sagsnummer
Hvilken type sagsnumre anvender du, og er de ens i antal tegn ?

og jeg har fået point nok, så vi klarer det fint uden :-)

altid 5 tegn

Denne som skal i alle ark untagen Total checker for 5 tegn
Man kan også teste for timer er indtastet
Hvis du ønsker det, så lad mig høre, men får først tid efter arb.tid i morgen

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G7:G2000")) Is Nothing Then Exit Sub
If Len(Target.Value) = 5 Then
Call Total
End If
If Len(Target.Value) <> 5 Then Beep: Beep
End Sub

1 der står altid et 0 (nul) nederst i d kolonnen (Sagsnummer) i Total hvor hulen kommer det fra

2 hvis man i "uge1" arket skriver "ryd indhold" i en given linie forsvinder data ikke fra "total"

1. det må være nisserne :-) - den skal jeg lige tænke over

2. hvis jeg skriver det samme i kolonne E så melder koden fejl
    det er forståeligt nok da den ikke kan addere tekst
i hvilken kolonne skriver du ryd indhold ?

1, kan man spore nullet

2 jeg skrev ryd indhold til hele linien i "uge 1"

1 nu læser jeg lige hvad du skriver, så jeg præcicerer: jeg h klikker og trykker "ryd indhold" undskyld min uklare formulering.

prøv denne med en On Error handler, så du kan slette i ugeark
søg også dine uge ark efter et 0, virker ok i mit ark

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G7:G2000")) Is Nothing Then Exit Sub
On Error Resume Next
If Len(Target.Value) = 5 Then
Call Total
End If
If Len(Target.Value) <> 5 Then Beep: Beep
End Sub

findes der en nem måde at kopiere ark 2 (uge 1) ud til alle 52 ark?

det virker i øvrigt fint nu.
Jeg syntes jeg skrev et par indlæg igår, de er væk nu!!!!!

Er ikke godt at vide hvor de blev af :-)

kopier ark (uge 1) til uge 2-52 skulle nok kunne lade sig gøre
Er de oprettet og tomme ?

er oprettet og ikke tomme, følger vba koden med

nej man kan ikke kopiere koden med en makro til de andre ark
var det det du mente ?

vil bare have den nemmeste løsning, copy paste 2X 52 gange er jo lidt vildt

er det koden eller det der er på arket eller begge del der skal kopieres ?

begge, desuden er der nogle kommentarer som ikke "bliver hvor de nu engang var placeret" de skal så ogsaå rettes i hvert enkelt ark

ok det som er på selve arket kan kopieres, ikke koden, men
tester lige om koden kan omskrives til at virke på alle ark hvis den indsættes i ThisWorkbook-moduler
Hvilket område på uge1 arket skal kopieres til de andre ?

a1 til i25

Denne kopierer Uge1!A1:I25 til Uge2-52 (incl. kommentarer)
obs. evt værdier i arkene 2-52 i det område slettes

Sub xCopy()
For t = 3 To 53
Sheets("Uge1").Range("A1:I25").Copy Sheets(t).Range("A1")
Next
End Sub

kikker på kode problemet efter spisetid

sejt den har jeg eglig manglet mange gange.
men hvorfor kan kommentarerne ikke fastholdes på de pladser jeg har sat dem på?

en anden ting, kan den tage højde for at rækker og kolonner har forskellige størrelser

og skal jeg ikke snart lave et nyt spm, så du kan få flere p?

Det kommer bag på mig hvis kommentarer ikke fastholdes som i Uge1
Det gør de i mit eks-ark.
kom lige med et eks på en kommentar som flytter fra ? til ?

Række/kolonne højde må kunne laves med kode kikker på det
det er A1:I25 vi snakker om stadig ikke ?

Denne indsættes i ThisWorkbook (den checker alle ark)
så skal der ikke være noget i ark-modulerne

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Sh.Range("G7:G2000")) Is Nothing Then Exit Sub
On Error Resume Next
If Len(Target.Value) = 5 Then
Call Total
End If
If Len(Target.Value) <> 5 Then Beep: Beep
End Sub

sejt kan jeg bare lade den stå eller skal den slettes

kan du også (please) lave en der sætter g1 til 1 i ark 2 (Uge 1) samt de efterfølgende (altså g1 i ark 3 (uge 2)) en højere Det er en uge tæller

Nej de koder du evt har i arkene skal slettes

m.h.t kolonnebredde/rækkehøjde :
marker det ark du har rettet ind desangående
hold SHIFT tasten nede og klik på det sidste ark, så alle bliver markeret
hvis du ikke kan se det sidste ark, bruger du bare pilene nede til venstre
Kolonne: marker de lodrette streger som adskiller kolonnerne og træk kolonne en anelse større end den var, og så tilbage igen
fortsæt med alle kolonner som har anden bredde end normal
samme fremgangsmåde for rækker.
så skulle alle markerede ark være med samme format som uge1

denne putter tal i G1, er på frihånd, men mon ikke den virker :-)

sub TALiG1()
for t=2 to 53
sheets(t).range("g1")=t-1
next
end sub

kolonnebredde / rækkehøjde kom fint nok med før Kommentar: excelent
05/12-2007 21:21:38

g1 er ok vil du ikke snart have fler p. om ikke andet skal vi kigge i morgen på jobbet så der kommer nok flere ønsker så laver jeg et nyt spm

nej 200 for spørgsmålet "nærmer forklaring" var nok lidt i overkanten, så nu er der vist balance i tingene. :-)

og ja spørg bare løs :-)

jeg er altså ikke så fedtet med p, det er vigtigere at få opgaverne løst.
Man kan godt snyde ved at lade sagsnummer stå tomt eller rydde indholdet i den. Men kan man ikke i den oprindelige kode indlægge at der skal være udfyldt i alle kolonner fra a til g før der flyttes data

så skulle den checke for a til f i den aktuelle række du taster i,
hvis den hver gang skal teste alle rækker i alle ark når du tilføjer et nyt sagsnummer, så skal vi rette i den anden kode, det må vente til i morgen.
m.h.t når/hvis du sletter et sagsnummer - den skal jeg lige tænke over :-)

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Sh.Range("G7:G2000")) Is Nothing Then Exit Sub
If Application.CountA(Sh.Range("A" & Target.Row & ":F" & Target.Row)) <> 6 Then Exit Sub
On Error Resume Next
If Len(Target.Value) = 5 Then
Call Total
End If
If Len(Target.Value) <> 5 Then Beep: Beep
End Sub

jeg har lige været borte et stykke tid men er nu tæt på at kunne afslutte.

Den opdaterer bare ikke når jeg ændre i eksempelvis c eller d er der et bud