11. marts 2013 - 15:34
Der er
1 kommentar og
1 løsning
Kopiere celler til næste tomme celle
Hej
Jeg mangler en makro, som skal samle en masse data for mig i et ark.
Der bliver noget manuelt, men jeg har brug for en funktion så jeg automatisk kan overføre data fra mit "indlæsning" ark til mit "data" ark.
Området A40 til F52 skal kopieres fra arket "indlæsning" som værdier til arket "data", startende i celle A2-F2.
Næste gang jeg vil indsætte "indlæsning" A40 til F52 i "data", skal den så indsætte efter næste tomme celle i række A, således at data kommer til at stå i en lang række efter hinanden, så jeg kan viderebehandle det i pivot/BI program.
Er der nogle der har en hurtig stump kode til det?
24. marts 2013 - 11:25
#1
Prøv nedenstående. Bemærk at filnavne og fanenavne skal ændres:
Sub CopyData()
Dim sMappe_fra, sArk_fra, sRange_fra, sMaxCol_fra As String
Dim sMappe_til, sArk_til, sRange_til As String
Dim lMaxRows_fra, lMaxRows_til As Long
sMappe_fra = "Kopiere celler til næste tomme celle.xlsm" ' Navnet på den åbne Excel-fil, der skal kopieres FRA
sMappe_til = "Kopiere celler til næste tomme celle.xlsm" ' Navnet på den åbne Excel-fil, der skal kopieres TIL
sArk_fra = "Indlæsning" ' Navnet på den fane, der skal kopieres FRA
sArk_til = "Data" ' Navnet på den fane, der skal kopieres TIL
lMaxRows_fra = Workbooks(sMappe_fra).Sheets(sArk_fra).Cells(Rows.Count, "A").End(xlUp).Row ' Antal rækker i FRA
lMaxRows_til = Workbooks(sMappe_til).Sheets(sArk_til).Cells(Rows.Count, "A").End(xlUp).Row ' Antal rækker i TIL
sMaxCol_fra = Workbooks(sMappe_fra).Sheets(sArk_fra).Cells(1, Columns.Count).End(xlToLeft).Address ' Mellemregning
sMaxCol_fra = Mid(sMaxCol_fra, 2, InStr(2, sMaxCol_fra, "$") - 2) ' Antal kolonner (antal i FRA bestemmer også antal i TIL
If (lMaxRows_til = 1) Then ' sArk_til er tom. Overskrifter i række 1 skal kopieres med.
sRange_fra = "A1:" & sMaxCol_fra & lMaxRows_fra
sRange_til = sRange_fra
Workbooks(sMappe_til).Sheets(sArk_til).Range(sRange_til) = Workbooks(sMappe_fra).Sheets(sArk_fra).Range(sRange_fra).Value ' Celleindhold kopieres
Else ' Der er data i sArk_til i forvejen. Overskrifter i række 1 skal IKKE kopieres med
sRange_fra = "A2:" & sMaxCol_fra & lMaxRows_fra ' Arealet i FRA, der skal kopieres
sRange_til = "A" & (lMaxRows_til + 1) & ":" & sMaxCol_fra & (lMaxRows_til + lMaxRows_fra - 1) ' Arealet i i TIL, der skal kopieres til.
Workbooks(sMappe_til).Sheets(sArk_til).Range(sRange_til) = Workbooks(sMappe_fra).Sheets(sArk_fra).Range(sRange_fra).Value ' Celleindhold kopieres
' ###################### NOTE #################
' Nedenstående linje gør kolonne A til et fortløbende nummer (dvs. at indhold fra kolonne A ikke kopieres)
' Skal kolonne A kopieres uændret, skal nedenstående linje slettes
Workbooks(sMappe_til).Sheets(sArk_til).Range("A" & lMaxRows_til).AutoFill Destination:=Workbooks(sMappe_til).Sheets(sArk_til).Range("A" & lMaxRows_til & ":A" & (lMaxRows_til + lMaxRows_fra - 1)), Type:=xlFillSeries
End If
End Sub
24. marts 2013 - 12:02
#2
Hej igen
Mit første løsningsforslag blev lidt for generel, og løste ikke opgaven. Det gør denne:
Sub CopyData2()
Dim sRange_til As String
Dim lRows_til As Long
lRows_til = ActiveWorkbook.Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
sRange_til = "A" & (lRows_til + 1) & ":F" & (lRows_til + 13)
ActiveWorkbook.Sheets("Data").Range(sRange_til) = ActiveWorkbook.Sheets("Indlæsning").Range("A40:F52").Value
End Sub
