Oprettet man. d. 07. januar 2013 kl. 13:07:16

Kibs
Kibs (4.190 point. Point ude: 30)


Kopier fra række indtil blank række

Hej

Jeg skal have lavet et loop af en slags. Som I kan se herunder skal jeg kopiere H2:J2, og sætte det ind i et andet ark i B2 (skal også transponeres). Derefter skal der køres en makro, og når den er kørt skal H3:J3 kopieres, makroen køres, og så fremdeles. Den skal så selv stoppe når der ikke længere er data i H.

    Sheets("Input").Select
    Range("H2:J2").Select
    Selection.Copy
    Sheets("Forside").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True

Er der nogle der kan omdanne ovenstående til det jeg ønsker?

Skrevet tir. d. 08. januar 2013 kl. 22:19:16| #1

H_Klein
H_Klein (10.270 point)
Hej Kibs,

Herunder to forslag til løsning.

Metode1 benytter den metode du efterlyser og kopierer én række af gangen.

Metode2 som er en del hurtigere, specielt hvis det drejer sig om mange data, kopierer ganske enkelt alle data fra "Input" - arket, (række 2 og nedefter) og sætter dem ind i arket "Forside".

Begge metoder tager højde for at der kan være data lagt ind i Forside-arket, og vil finde første ledige celle nedefter hvis pågældende celle er optaget.

---------------------------------
Sub metode1()

    Dim rk As Long
   
    Sheets("Input").Select
    rk = 2
    Do
    Cells(rk, 8).Select
    Range(Cells(rk, 8), Cells(rk, 10)).Select
    Selection.Copy
    Sheets("Forside").Select
    Cells(1, 2).Select
    If Cells(2, 2) = "" Then
    Cells(2, 2).Select
    ActiveSheet.Paste
    Else
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    End If
    Sheets("Input").Select
    rk = rk + 1
    Loop Until Cells(rk, 8) = ""
    Application.CutCopyMode = False
End Sub
--------------------------------------------------

--------------------------------------------------
Sub metode2()

    Sheets("Input").Select
    Cells(2, 8).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Forside").Select
    Cells(1, 2).Select
    If Cells(2, 2) = "" Then
    Cells(2, 2).Select
    ActiveSheet.Paste
    Else
    Cells(1, 2).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    End If
    Application.CutCopyMode = False
End Sub
----------------------------------------

Håber at det kan bruges og ellers må du lige vende tilbage.

Med venlig hilsen

Henrik

Skriv et indlæg




Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] [img]link til billede[/img]
Web- og emailadresser omdannes automatisk til links

Log ind

   


Seneste spørgsmål

væftet PDF fil til mail, hvor stien ligger i en celle...

Oprettet den 25. februar 2015 kl. 20.06
malldiverne giver 100 point for svar | Giv et svar »

Sortere data i array

Oprettet den 25. februar 2015 kl. 14.19
MRPMRP giver 120 point for svar | Giv et svar »

Send enkelt mail, med flere oplysninger?

Oprettet den 23. februar 2015 kl. 10.20
malldiverne giver 60 point for svar | Giv et svar »






Computerworld

Teaser billede

"Når folk ser min tatovering, spørger de som regel, om den er ægte. Og det er den altså"

"Jeg går vildt meget op i ECM, og det har jeg gjort i 13-14 år. Jeg synes, at det er skidespændende og det sejeste i hele verden, og der er faktisk ikke noget bedre. Jeg har også skrevet en...

CIO

Teaser billede

Google klar med 'Android for Work' - sådan vil Google få virksomhederne til at skifte til Android

Google ser store muligheder for indtjening, hvis selskabet kan få virksomhederne til at vælge Android som mobil-platform. Nu er selskabet klar med særlig 'Android for Work'-løsning.

Comon

Teaser billede

Førstehåndsindtryk: Samsung Galaxy S6 og S6 edge er den helt rigtige vej for Samsung

Samsung Galaxy S6 og S6 Edge er de to nye telefoner fra Samsung, der skal vende den nedadgående kurve for selskabet. Kom med og få vores førstehåndsindtryk.

Channelworld

Teaser billede

Microsoft svinger pisken over sine forhandlere: Flere kunder skal op i skyen

Forhandlere, der sælger abonnementer på Microsofts Office 365, gør ikke nok at sende kunderne op i skyen, mener Microsoft.

White paper

Teaser billede

Best practices for udvikling af sikre apps

MaaS360 by Fiberlink tilbyder best practices så du kan sørge for mobil-applikationernes sikkerhed, når din virksomhed udvikler og udruller apps.



Udgiver · © 2015 Computerworld A/S · Hørkær 18 · 2730 Herlev · Tlf.: 77 300 300 · Fax: 77 300 301 · Brug af personoplysninger