Søg
Avatar billede CarstenPilgaard Nybegynder
05. april 2013 - 11:00 Der er 11 kommentarer og
1 løsning

Overføre fra et ark til et andet

Microsoft Excel 2010

Hej

Er ikke superbruger af Excel, men har dog arbejdet en del med det. Har søgt en del på nettet og i Excel hjælpen for at finde en løsning på min opgave. Det er ikke lykkedes og nu vil jeg høre om der skulle være svar at finde i dette forum.

Skal have skrevet en kode således at jeg kan kopiere tekst udtrukket fra et andet program ind i 3 rækker på "Ark2" og så skal de overføres til "Ark1" så de kommer ud på labels.


"Ark1"er et konfigureret ark indeholdende 51 rækker og et uendeligt antal kolonner. Det er opsat således at den sidste kolonne på side 1 er M og den sidste række på alle sider er 51.
Det er opdelt således at det kan udskrive på labels med 3 tekstlinier (eks. A1, A2, A3) og der er 13*13 labels (169) på hvert ark (side)


"Ark2" er et ark indeholdende 3 rækker og et uendeligt antal kolonner. Disse data udtrækkes andetsteds fra og står altid i 3 rækker og et forskelligt antal kolonner
Data fra "Ark2" skal flyttes (eller kopieres) ind i "Ark1"

"Ark2" A1,A2,A3 flyttes over i "Ark1" A1,A2,A3 (tekstegenskaber i "Ark1" bibeholdes)
"Ark2" A1,A2,A3 flyttes over i "Ark1" B1,B3,B2 (tekstegenskaber i "Ark1" bibeholdes)
"Ark2" B1,B2,B3 flyttes over i "Ark1" C1,C2,C3 (tekstegenskaber i "Ark1" bibeholdes)
"Ark2" B1,B2,B3 flyttes over i "Ark1" D1,D3,D2 (tekstegenskaber i "Ark1" bibeholdes)
Osv.

Som det kan ses af ovenstående laves der to labels af hver kolonne fra "Ark2", dog er linie 2 og linie 3 på labelen byttet.

Det er måske lidt svært at forstå hvordan data skal havne på "Ark1" men har Excel-filen der forklarer skulle forklare det hele. Den kan hentes her http://gupl.dk/694601/

Mvh. Carsten Pilgaard
Avatar billede vagn99 Nybegynder
05. april 2013 - 12:17 #1
Dit lille problem er tilsyneladende, at høje kolonner rykker 2, mens 1 ark kun rykker 1
hvis du nu kunne indsætte en søjle mellem hver data ville du kunne lave en simpel kopiering.
Alternativt anbringe label 2 under label 1 i stedet for ved siden af label 1.
Sidste og sværere, kopiere over i en indirekte funktion med udregning af kollonneforskydning, men den tager det mig lidt tid at finde frem, til så det vil jeg overlade til en af nørderne.
Nogle af dem ryster bare disse lange formler ud af ærmet.
Avatar billede CarstenPilgaard Nybegynder
05. april 2013 - 12:56 #2
Det er nok korrekt, men en simpel kopiering vil ikke løse problemet med den anden label hvor linie 2 og linie 3 er byttet om.
Avatar billede kabbak Professor
05. april 2013 - 12:58 #3
Public Sub MakeLabels()
Dim Cl As Long, A As Long, X As Long, S As Integer
Dim Data As Variant, Temp As Variant
Cl = Worksheets("Ark2").Range("A1").End(xlToRight).Column
S = 0
I = 1
A = 1
X = 1
With Worksheets("Ark2")
Do
For I = I To 12 Step 2

  Data = .Range(.Cells(1, A), .Cells(3, A))
 
Worksheets("Ark1").Range(Cells(X, I + S), Cells(X + 2, I + S)) = Data
Temp = Data(2, 1)
Data(2, 1) = Data(3, 1)
Data(3, 1) = Temp
Worksheets("Ark1").Range(Cells(X, I + 1 + S), Cells(X + 2, I + 1 + S)) = Data
  A = A + 1
  Next
  Data = .Range(.Cells(1, A), .Cells(3, A))
  Worksheets("Ark1").Range(Cells(X, I + S), Cells(X + 2, I + S)) = Data
  I = 1
  X = X + 4
  If X = 49 Then
    S = S + 13
    X = 1
    End If
Temp = Data(2, 1)
Data(2, 1) = Data(3, 1)
Data(3, 1) = Temp

  Worksheets("Ark1").Range(Cells(X, I + S), Cells(X + 2, I + S)) = Data
 
  Loop Until A >= Cl
  End With

End Sub
Avatar billede CarstenPilgaard Nybegynder
05. april 2013 - 13:31 #4
Tak for det kabbak

Det virker efter hensigten, dog har jeg måske ikke forklaret mig tydeligt nok. Den skulle gerne fortsætte med at indsætte data fra de 3 rækker på "Ark2" hvis nu der eksempelvis er data i 250 kolonner...
Så hvis den kunne fortsætte indtil den møder en tom kolonne ville det som det ser ud løse mit problem :)java script: void(0);
Avatar billede kabbak Professor
05. april 2013 - 13:35 #5
det skulle den helst også gøre, har du testet ??
Avatar billede CarstenPilgaard Nybegynder
05. april 2013 - 13:49 #6
Har testet ja, og den overfører kun de første 13 kolonner.
Der er også en smutter ved M1,M2,M3 som er samme "label" som A5,A6,A7...

fil: http://gupl.dk/694606/
Avatar billede kabbak Professor
05. april 2013 - 15:14 #7
kan vi ikke bare stryge kolonne 13, så der det nemmere

Fordi den ikke fandt alle, var fordi der ikke var huller i række 1

Public Sub MakeLabels()
Dim Cl As Long, A As Long, X As Long, S As Integer, I As Long
Dim Data As Variant, Temp As Variant
With Worksheets("Ark2")
Cl = .Range("B1").CurrentRegion.Columns.Count
S = 0
I = 1
A = 1
X = 1

Do
For I = 1 To 12

    Data = .Range(.Cells(1, A), .Cells(3, A))
  If I Mod 2 <> 0 Then
        Worksheets("Ark1").Range(Cells(X, I + S), Cells(X + 2, I + S)) = Data ' label 1
  Else
        Temp = Data(2, 1)
        Data(2, 1) = Data(3, 1)
        Data(3, 1) = Temp
        Worksheets("Ark1").Range(Cells(X, I + S), Cells(X + 2, I + S)) = Data ' label 2
  End If

  If A >= Cl Then Exit Sub
  If I Mod 2 = 0 Then A = A + 1
  Next
  X = X + 4 ' række
 
  If X > 49 Then ' ny side
    S = S + 13 ' sidebredde
    X = 1
 
    End If
  Loop
  End With

End Sub
Avatar billede vagn99 Nybegynder
06. april 2013 - 14:57 #8
#2
Min lille løsning ville nu klare problemet, for jeg vil kun foretage kopiering fra ar1 til ar2 første label. Den næste ville jeg kopiere fra den flyttede med intern kopiering celle for celle og blot bytte celle 2 og celle3.
Men den programmerede løsning er da langt finere.
Avatar billede kabbak Professor
06. april 2013 - 15:36 #9
prøv denne, nu med alle labels

Option Base 1
Public Sub MakeLabels()
Dim Cl As Long, A As Long, X As Long, S As Integer, I As Long
Dim Data1 As Variant, Data2 As Variant, Temp As Variant
Worksheets("Ark2").Activate
Cl = Worksheets("Ark2").UsedRange.Columns.Count
ReDim Data2(Cl * 2, 3)
I = 1
Data = Application.WorksheetFunction.Transpose(Worksheets("Ark2").Range(Cells(1, 1), Cells(3, Cl)))
For X = 1 To UBound(Data2, 1) Step 2
Data2(X, 1) = Data(I, 1)
Data2(X, 2) = Data(I, 2)
Data2(X, 3) = Data(I, 3)
Data2(X + 1, 1) = Data(I, 1)
Data2(X + 1, 2) = Data(I, 3)
Data2(X + 1, 3) = Data(I, 2)
I = I + 1
Next

S = 0
I = 1
A = 1
X = 1
With Worksheets("Ark1")

Do
For I = 1 To 13
    If A >= Cl * 2 Then Exit Sub
    .Cells(X, I + S) = Data2(A, 1)
    .Cells(X + 1, I + S) = Data2(A, 2)
    .Cells(X + 2, I + S) = Data2(A, 3)
    A = A + 1
  Next
  X = X + 4 ' ny række
 
  If X > 49 Then ' ny side
    S = S + 13 ' sidebredde
    X = 1
 
    End If
  Loop
  End With

End Sub
Avatar billede kabbak Professor
06. april 2013 - 15:42 #10
lidt ændringer.

Option Base 1
Public Sub MakeLabels()
Dim Cl As Long, A As Long, X As Long, S As Integer, I As Long
Dim Data1 As Variant, Data2 As Variant, Temp As Variant
Worksheets("Ark1").Cells.ClearContents
Worksheets("Ark2").Activate
Cl = Worksheets("Ark2").UsedRange.Columns.Count
ReDim Data2(Cl * 2, 3)
I = 1
Data = Application.WorksheetFunction.Transpose(Worksheets("Ark2").Range(Cells(1, 1), Cells(3, Cl)))
For X = 1 To UBound(Data2, 1) Step 2
Data2(X, 1) = Data(I, 1)
Data2(X, 2) = Data(I, 2)
Data2(X, 3) = Data(I, 3)
Data2(X + 1, 1) = Data(I, 1)
Data2(X + 1, 2) = Data(I, 3)
Data2(X + 1, 3) = Data(I, 2)
I = I + 1
Next

S = 0
I = 1
A = 1
X = 1
With Worksheets("Ark1")

Do
For I = 1 To 13
    If A >= Cl * 2 Then
    Worksheets("Ark1").Activate
    Exit Sub
    End If
    .Cells(X, I + S) = Data2(A, 1)
    .Cells(X + 1, I + S) = Data2(A, 2)
    .Cells(X + 2, I + S) = Data2(A, 3)
    A = A + 1
  Next
  X = X + 4 ' ny række
 
  If X > 49 Then ' ny side
    S = S + 13 ' sidebredde
    X = 1
 
    End If
  Loop
  End With

End Sub
Avatar billede CarstenPilgaard Nybegynder
08. april 2013 - 08:44 #11
Tak for det kabbak

Har netop testet og det fungerer perfekt! Sparer meget indtastningstid :)
Ved ikke hvordan man giver de der point??
Avatar billede kabbak Professor
08. april 2013 - 09:27 #12
jeg giver et svar, så kan du
Avatar billede Ny bruger Nybegynder

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.

Loading billede Opret Preview
Kategori
Excel kurser
Excel kurser for alle niveauer og behov – find det kursus, der passer til dig
Se alle Excel kurser

Flere spørgsmål fra Excel kategorien

Titel Indlæg Oprettet Seneste aktivitet
Kho Sim Số Đẹp Giá Rẻ, Uy Tín Lớn Nhất Việt Nam! Af khosimcom i Excel 0 I dag 04:46 -
Makro der gemmer vedhæftet fil fra Msg og omdøber filen Af lokesa i Excel 2 31/03/202610:22 31/03/202611:47
Stempel ur start og stop Af lurup i Excel 2 23/03/202613:24 31/03/202610:27
Hvordan bruges indeks & sammenlign når der skal søges over flere kolonner? Af Laugesen1 i Excel 4 08/03/202611:56 08/03/202613:57
Tips til at mestre Excel hurtigt Af MonikaG32 i Excel 4 04/03/202617:11 06/03/202609:37
Se alle spørgsmål i kategorien Opret spørgsmål

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Opret Log ind

Du kan også logge ind via nedenstående tjenester

Alle kategorier på Eksperten
Seneste spørgsmål Seneste aktivitet
I dag 04:46 Kho Sim Số Đẹp Giá Rẻ, Uy Tín Lớn Nhất Việt Nam! Af khosimcom i Excel
31/0310:22 Makro der gemmer vedhæftet fil fra Msg og omdøber filen Af lokesa i Excel
30/0313:45 Kablet forbindelse mellem android telefon og windows 11 pc Af 1Dorte i Android
30/0312:04 Elementtype vises - og ikke billedet? Af hkprofil i Billedbehandling
29/0312:08 Problemer med replay af købte kursusvideoer Af annam i Browsere
White papers
Flere white papers »