Excel makra, kopirovani dat

[medic911]

Dobry den,
mam v jednom listu ve sloupci napsane adresy. Chtel bych z tohoto listu pomoci maker adresu zkopirovat do jineho listu na urcite misto, dalsi adresu do jineho listu na stejne urcene misto. Adresy jsou v jednom sloupci a vzdy maji 4 radky pak jeden radek volny a zase 4 radky adresy.

Mohl by mi stim nekdo pomoct?

[Reklama]

[smicrle]

Sub vladr()
'
' Makro na vložení adresy
'

'
Range("A1:A4").Select
Selection.Copy
Sheets("List2").Select
ActiveSheet.Paste
Sheets("List1").Select
Range("A6:A9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("List3").Select
ActiveSheet.Paste
Sheets("List1").Select
Range("A11:A14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("List4").Select
ActiveSheet.Paste
End Sub


A tak můžeš dál pokračovat. Vloží se ti to na aktivní buňku v listu. Můžeš si to změnit aby ti to dalo do určitých buňěk.

[cmuch]

To smicrle:
tak za toto by Vás tu i jinde ukamenovali

Použil bych toto, jelikož toho nebylo moc napsáno tak si to budete muset doupravit

Kód: Vybrat vše

Sub AddAdres()
  Dim shAdresy As Worksheet
  Dim iRowsOffset As Integer

  Set shAdresy = Sheets("Adresy")  'list s adresama
  iRowsOffset = 1                        'pomocne pro offset dalsi adresy

  'projdi listy sesitu
  For Each sh In ThisWorkbook.Sheets
    'pokud jsou rozdilne od listu shAdresy proved
    If sh.Name <> shAdresy.Name Then
      'vloz adresy od do ciloveho listu ("A5") z shAdresy ("A1")
      sh.Cells(5, "A").Resize(4, 1).Value = shAdresy.Cells(1, "A").Resize(4, 1).Offset(iRowsOffset, 0).Value
      'offset pro dalsi adresu
      iRowsOffset = iRowsOffset + 5
    End If
  Next
End Sub

[smicrle]

To cmuch:
Já bych se za toto mít ve vlastním souboru taky kamenoval. Ale šel jsem mu naproti cestou nejmenšího odporu. Si myslím že to moc nezná tak tomu jednoduchému kódu porozumí.

[medic911]

Dekuji oboum za odpovedi. Ano zacinam stim a tak me postourani v obou kodech jen prospeje. :)