Temat: makro: kopiowanie zakresu komórek z przesunięciem

tytuł tematu trochę zagmatwany, ale już wyjaśniam.

Mam takie testowe makro:

Sub testowe()
'
' testowe Makro
'

'
Sheets("kohezja").Select
Range("G1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("kohezja").Select
Range("P10:S10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("kohezja").Select
Range("P4:S4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("kohezja").Select
Range("P5:S5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("C10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("kohezja").Select
Range("P6:S6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("C14").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("kohezja").Select
Range("P7:S7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("C18").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("kohezja").Select
Range("P8:S8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("C22").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("kohezja").Select
Range("P9:S9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("C26").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End Sub

Generalnie zatem stałe i niezmienne zakresy komórek z arkusza "kohezja" kopiuję do kolumn w arkuszu "agregacja". Makro działa ale kopiuje mi tylko do kolumny C, a chciałbym, żeby po każdym kliknięciu przycisku aktywującego makro kopiowało mi dane do kolejnej wolnej kolumny. I nie wiem jak to zrobić :(

Temat: makro: kopiowanie zakresu komórek z przesunięciem

Należy znaleźć ostatnią zajętą kolumnę np.
***

Dim lastCol as Long

With ThisWorkbook.Worksheets("agregacja")

  lastCol = .Cells(1,.Columns.Count).End(xlToLeft).column

End With

I zamiast wklejać dane np. do Range(C2), wkleja Pan do :

Cells(2,lastCol+1)

***Zakładam że pierwszy wiersz zawsze jest wypełniony jakimiś danymi.

Temat: makro: kopiowanie zakresu komórek z przesunięciem

Łukaszu,

ja nie za bardzo łapię VBA :(

jeżeli byłbyś tak uprzejmy i w pliku: http://parr.com.pl/pub/makro.xlsx naniósł swoje sugestie byłbym niezwykle wdzięczny.

Temat: makro: kopiowanie zakresu komórek z przesunięciem

Drobna aktualizacja.

Chciałbym aby wartości wklejały się wierszami. w arkuszu "agregacja" od wiersza nr 3 i począwszy od komórki A3 w dół

Temat: makro: kopiowanie zakresu komórek z przesunięciem

Makro teraz wygląda tak:

Sub agregacja()
'
' agregacja Makro
'
'
Sheets("agregacja").Select
Range("A3").Select
Sheets("kohezja").Select
Range("G1").Select
Selection.Copy
Sheets("agregacja").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("kohezja").Select
Range("P10:S10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("B3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("kohezja").Select
Range("P4:S4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("F3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("kohezja").Select
Range("P5:S5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("J3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("kohezja").Select
Range("P6:S6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("N3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("kohezja").Select
Range("P7:S7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("R3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("kohezja").Select
Range("P8:S8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("V3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("kohezja").Select
Range("P9:S9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("agregacja").Select
Range("Z3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A4").Select
End Sub

Generalnie zatem stałe i niezmienne zakresy komórek z arkusza "kohezja" kopiuję do kolejnych wierszy w arkuszu "agregacja" począwszy od wiersza nr 3 (komórka A3). Makro działa ale kopiuje mi tylko do wiersza 3, a chciałbym, żeby po każdym kliknięciu przycisku aktywującego makro kopiowało mi dane do kolejnego wolnego wiersza.

Plik do pobrania jest pod: http://parr.com.pl/pub/makro.xlsm

Dziękuję za pomoc!

Temat: makro: kopiowanie zakresu komórek z przesunięciem

Edytor VBA (VBEditor) - menu - Insert - Module. Tam wklej

Sub Kopiuj_Dane()

Dim wiersz As Long

Dim Arkusz As Worksheet



Set Arkusz = Sheets("agregacja")

With Arkusz

    On Error Resume Next

    wiersz = .Range("A" & .Rows.Count).End(xlUp).Row + 1

    If Err.Number > 0 Or wiersz < 3 Then

        MsgBox "Brak nagłówka albo ....", vbCritical

        Exit Sub

    End If

    On Error GoTo 0

    Err.Clear

End With

Application.ScreenUpdating = False

With Sheets("kohezja")

    .Range("G1").Copy

    Arkusz.Range("A" & wiersz).PasteSpecial Paste:=xlPasteValues

    .Range("P10:S10").Copy

    Arkusz.Range("B" & wiersz).PasteSpecial Paste:=xlPasteValues

    .Range("P4:S4").Copy

    Arkusz.Range("F" & wiersz).PasteSpecial Paste:=xlPasteValues

    .Range("P5:S5").Copy

    Arkusz.Range("J" & wiersz).PasteSpecial Paste:=xlPasteValues

    .Range("P6:S6").Copy

    Arkusz.Range("N" & wiersz).PasteSpecial Paste:=xlPasteValues

    .Range("P7:S7").Copy

    Arkusz.Range("R" & wiersz).PasteSpecial Paste:=xlPasteValues

    .Range("P8:S8").Copy

    Arkusz.Range("V" & wiersz).PasteSpecial Paste:=xlPasteValues

    .Range("P9:S9").Copy

    Arkusz.Range("Z" & wiersz).PasteSpecial Paste:=xlPasteValues

    Application.CutCopyMode = False

    Arkusz.Range("A1").Activate

End With

Application.ScreenUpdating = True

End Sub

Makro bez finezji, z adresowaniem komórek łatwym do ręcznej poprawki.Ten post został edytowany przez Autora dnia 22.03.14 o godzinie 10:21

Temat: makro: kopiowanie zakresu komórek z przesunięciem

Bogdanie,

makro działa, ale wkleja mi od wiesza 4, pomijając wiersz 3 :(

zaktualizowany plik o Twoje makro: http://parr.com.pl/pub/makro.xlsm

Temat: makro: kopiowanie zakresu komórek z przesunięciem

Nie zwróciłem uwagi, że przygotowane dane do wpisywania są ujęte w TABELĘ.
W takim przypadku metoda End() może zwrócić niepoprawny numer wiersza. Jeżeli masz 100% gwarancji, że w A1/A2 masz nagłówki to podmień linijkę kodu obliczającego numer wolnego wiersza na następującą

wiersz = .Range("A1").CurrentRegion.Rows.Count + 1

i powinno działać bez problemu.

Temat: makro: kopiowanie zakresu komórek z przesunięciem

Bogdanie,

jak zwykle NIEOMYLNIE :)

Ukłony!