07. januar 2013 - 13:07
Der er
1 kommentar
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?
08. januar 2013 - 22:19
#1
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
