Makro og VBA - Data kopiering

Print side | Luk vindue

Data kopiering

Udskrevet fra: Dansk Regneark Forum
Kategori: Hjælp til regneark.
Forum navn: Makro og VBA
Forum beskrivelse: Hjælp til Makroer og VBA-programmering
Web-adresse: https://forum.excel-regneark.dk/forum_posts.asp?TID=191
Udskrevet den: 12.Dec.2024 kl. 15:13

Emne: Data kopiering

Besked fra: Goldie
Emne: Data kopiering
Posteringsdato: 14.Jan.2011 kl. 17:14

Jeg sidder i øjeblikket med et ønske om at kunne kopiere visse data fra et ark til et andet ark i samme projektmappe.

Arket "Master" indeholder alle data.

De rækker som indeholder Printer i kolonne A skal kopieres til arket "Printer" Server til arket "Server" o.s.v.

jeg har vedhæftet ën testfil. ( en enkelt celle kan jeg godt finde ud af (hvis formel) men det er hele rækken der skal kopieres)

Jeg har forgæves søgt på nettet men ikke været i stand til at finde noget der virker. Derfor håber jeg der er en der kan hjælpe eller fortælle at det ikke kan lade sig gøre.

På forhånd tak

/uploads/158/Testkopiering.xlsx - uploads/158/Testkopiering.xlsx

Svar:

Besked fra: Allan
Posteringsdato: 15.Jan.2011 kl. 01:17

Hej Goldie,

Jeg ved ikke om du er bekendt med VBA, men denne lille stump kan løse dit problem.

For hver gang den møder et navn i kolonne A på arket "Master", kopieres hele rækken til arket med samme navn.

Hvis du opretter nye ark med nye navne, vil koden automatisk tage højde for det, det enske ark som er fast kodet er "Master".

Sub KopierTilFaner()
Application.ScreenUpdating = False
For Each c In Sheets("Master").Range("A1:A100").Cells
    If c.Value <> "" Then
        On Error Resume Next
        If Sheets(c.Value) Is Nothing Then
        Else
        On Error GoTo 0
            c.EntireRow.Copy
            Sheets(c.Value).Activate
            Range("A100").End(xlUp).Offset(1, 0).Select
            ActiveSheet.Paste
        End If
    End If
Next c
Application.CutCopyMode = False
Sheets("Master").Select
End Sub

Skal du have hjælpe til at lægge koden i dit fil?

//Allan

Besked fra: rassten
Posteringsdato: 15.Jan.2011 kl. 02:12

En metode kunne være


Sub a_test()
Sheets("Master").Activate
LR = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LR Step 1
    If Cells(i, 1).Value = "Server" Then
    Rows(i).Copy Destination:=Worksheets("Server").Range("a" & 1 + (Worksheets("Server").Cells(Rows.Count, 1).End(xlUp).Row))
    ElseIf Cells(i, 1).Value = "Printer" Then
    Rows(i).Copy Destination:=Worksheets("Printer").Range("a" & 1 + (Worksheets("Printer").Cells(Rows.Count, 1).End(xlUp).Row))
    ElseIf Cells(i, 1).Value = "Disk" Then
    Rows(i).Copy Destination:=Worksheets("Disk").Range("a" & 1 + (Worksheets("Disk").Cells(Rows.Count, 1).End(xlUp).Row))
    
End If

Next i
End Sub

Men ellers kan du også altid bruge "filter" metoden

Besked fra: Goldie
Posteringsdato: 16.Jan.2011 kl. 08:57

Hej Allan

Mange tak for svaret.

Nej jeg er ikke en haj til VBA men har lagt din kode ind i Arket master. Det er desværre ikke lykkedes for mig at få det til at køre .

Error Run-Time Error '1004':

Application-defined or object-defined error

//Goldie

Besked fra: Goldie
Posteringsdato: 16.Jan.2011 kl. 09:00

Hej Rassten

Jeg takker også dig for svaret..

Jeg har også prøvet dit forslag.. Fungerer men.....

For hver gang jeg kører dit script bliver de relevante rækker kopieret. Kan det lade sig gøre at det kun bliver gjort en gang.

//Goldie

Besked fra: rassten
Posteringsdato: 16.Jan.2011 kl. 12:22

Error Run-Time Error '1004':

Application-defined or object-defined error

Skyldes at du har lagt koden det forkerte sted.
I vba-editoren vælg menuen "Insert" - vælg "Module", her skal koden så indsættes

Besked fra: rassten
Posteringsdato: 16.Jan.2011 kl. 12:40

Denne gør at data på arkene Server osv. bliver slettet


Sub a_1_test()
Application.ScreenUpdating = False
Sheets("Server").Activate
LR = Cells(Rows.Count, 1).End(xlUp).Row
If LR > 2 Then Rows("2:" & LR).ClearContents

Sheets("Printer").Activate
LR = Cells(Rows.Count, 1).End(xlUp).Row
If LR > 2 Then Rows("2:" & LR).ClearContents

Sheets("Disk").Activate
LR = Cells(Rows.Count, 1).End(xlUp).Row
If LR > 2 Then Rows("2:" & LR).ClearContents


Sheets("Master").Activate
LR = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LR Step 1
    If Cells(i, 1).Value = "Server" Then
    Rows(i).Copy Destination:=Worksheets("Server").Range("a" & 1 + (Worksheets("Server").Cells(Rows.Count, 1).End(xlUp).Row))
    ElseIf Cells(i, 1).Value = "Printer" Then
    Rows(i).Copy Destination:=Worksheets("Printer").Range("a" & 1 + (Worksheets("Printer").Cells(Rows.Count, 1).End(xlUp).Row))
    ElseIf Cells(i, 1).Value = "Disk" Then
    Rows(i).Copy Destination:=Worksheets("Disk").Range("a" & 1 + (Worksheets("Disk").Cells(Rows.Count, 1).End(xlUp).Row))
    
End If
Next i
Application.ScreenUpdating = True
End Sub

Besked fra: rassten
Posteringsdato: 16.Jan.2011 kl. 13:49

Denne variant sletter ikke noget.
Men bruger kolonne AA som hjælpe kolonne. De allerede flyttede data bliver i kolonne AA markeret med et "x", så kun de rækker som der ikke i kolonne AA er markeret med et "x" bliver flyttet næst gang makroen kører.
Bemærk at kolonne AA bliver skjult


Sub a_2_test()
Application.ScreenUpdating = False

Sheets("Master").Activate
Columns("AA:AA").EntireColumn.Hidden = False
FR = Cells(Rows.Count, 1).End(xlUp).Row
For a = FR To 2 Step -1
    If Range("AA" & a) = "x" Then
    Rows(a).EntireRow.Hidden = True
    End If
Next a

LR = Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To LR Step 1
    If Cells(i, 1).Value = "Server" Then
    Rows(i).Copy Destination:=Worksheets("Server").Range("a" & 1 + (Worksheets("Server").Cells(Rows.Count, 1).End(xlUp).Row))
    ElseIf Cells(i, 1).Value = "Printer" Then
    Rows(i).Copy Destination:=Worksheets("Printer").Range("a" & 1 + (Worksheets("Printer").Cells(Rows.Count, 1).End(xlUp).Row))
    ElseIf Cells(i, 1).Value = "Disk" Then
    Rows(i).Copy Destination:=Worksheets("Disk").Range("a" & 1 + (Worksheets("Disk").Cells(Rows.Count, 1).End(xlUp).Row))
    
End If
Next i

Range("AA2:AA" & FR).EntireRow.Hidden = False
Range("AA2:AA" & FR) = "x"
Columns("AA:AA").EntireColumn.Hidden = True

Application.ScreenUpdating = True
End Sub

Besked fra: Allan
Posteringsdato: 16.Jan.2011 kl. 20:04

Hej Goldie,

Prøv lige at se denne fil, jeg har forsynet funktionen med en knap på arket 'Master' som du kan teste funktionen med.

Den virker ved at alle data på arkene 'Server', 'Printer' og 'Disk' bliver slettet inden data kopieres over.

Derefter køres funktionen så alle rækker kopieres over på det ark som matcher navnet i cellerne.

/uploads/1/Testkopiering2.xls - uploads/1/Testkopiering2.xls

Kan dette løse din udfordring?

//Allan

Besked fra: Goldie
Posteringsdato: 17.Jan.2011 kl. 10:57

Hej

Super... det er lige det der løser opgaven..

Jeg takker mange gange jer begge for svar..

//Goldie

Besked fra: Allan
Posteringsdato: 17.Jan.2011 kl. 17:17

Hej Goldie,

50% velbekomme herfra

Tak for din tilbagemelding.

//Allan

-------------
MVH

Allan
https://www.excel-regneark.dk" rel="nofollow - Excel-regneark.dk - Gratis skabeloner til Excel
Få over 120 ekstra funktioner med Danmarks bedste add-in

Print side | Luk vindue