• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

MS Excel

Téma: Kopírování polí

Zaslal/a spitffire 25.1.2016 15:22

Dobrý den,
nedaří se mi operace: z listu 1 pomocí VBA vykopírovat textové hodnoty z buněk G5 až dokud není prázdná buňka(třeba do G50) do druhého listu 2, první hodnota v bunce A1 další do B1 pak C1 pak A2,B2,C2,A3,B3,C3... v podstatě se to bude kopírovat pouze do prvních 3 sloupců.
Věděl by někdo jak na to ? :/
Děkuji


Sub Copy()

Dim i As Integer
Dim j As Integer

Dim q As Range, r As Long, s As Range

For j = 1 To 10
For i = 1 To 3

With Worksheets("Data")
For r = 5 To .Cells(.Rows.Count, 1).End(xlUp).Row Step 1
Set q = .Range(.Cells(r, 7), .Cells(r, .Cells(r, .Columns.Count).End(xlToLeft).Column))
With Worksheets("Copy")
Set s = .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1)
End With
q.Copy s

Cells(j, i).Value = q

Next r
End With
Next i
Next j

End Sub

Zaslat odpověď >

---

Strana:  1 2   další »

eLCHa(25.1.2016 16:11)#029552

Nevím, jestli jsem vás pochopilSub subCopy()
With Worksheets("Data")
With .Range(.Range("G5"), .Cells(.Rows.Count, 7).End(xlUp))
With Worksheets("Copy").Cells(1).Resize(.Rows.Count \ 3 + 1, 3).Cells
.Formula = "=TEXT(OFFSET(Data!$G$5,(ROW()-1)*3+MOD(COLUMN()+2,3),0),""#"")"
.Value = .Value
End With 'Worksheets("Copy").Cells(1).Resize(.Rows.Count \ 3 + 1, 3).Cells
End With '.Range(.Range("G5"), .Cells(.Rows.Count, 7).End(xlUp))
End With 'Worksheets("Data")
End Subcitovat

spitffire(25.1.2016 16:55)#029555

Pochopil jste mě skvěle Funguje!
Mockrát Vám děkuji!!
Kdybych mohl být tak smělý a pokud byste si našel chvilku pro stručné vysvětlení kódu?
Ještě jednou díky. :)citovat

eLCHa(25.1.2016 17:08)#029556

Jamalalicha? Jamalalicha. Jamalalicha, i paprťála, chánua, chánua, e chánua, e chánu, džalala, džalala-a, a paprťála. Tasparta maznalika zamáz piskurty, jarda, piskurty, patláma, patláma, patláma a… žbrluch!

Mno když stručně, tak nějak takhle ;)))

Zjistím počet buněk, podle toho nastavím výslednou oblast, do ní dám ten vzorec a pak to přetento na tento - hodnoty.citovat

spitffire(25.1.2016 17:13)#029557

:D Díkycitovat

eLCHa(25.1.2016 17:34)#029558

Asi není zač.
Musíte se ptát konkrétně čemu nerozumíte. Já už jsem totiž tak zdegenerovaný, že mi to přijde jasné a že na tom není co vysvětlovat.citovat

vovka.h(25.1.2016 18:15)#029560

Jamalálicha: ono by to šlo taky přes pole bez vzorce: Žbrluch!citovat

eLCHa(25.1.2016 18:21)#029561

@vovka
Já vím. Ale nechtělo se mi přemýšlet.citovat

elninoslov(25.1.2016 23:29)#029563

@ spitffire: Títo 2 páni by Vám to asi urobili peknejšie, ale toto máte odo mňa na dobrú noc :)
Sub Copy_1_To_3_Columns()
Dim P, D(), x As Integer, y As Long, r As Long, s As Integer
With Worksheets("List1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
P = .Cells(1, 1).Resize(r)
End With
s = r \ 3
ReDim D(1 To s + 1, 1 To 3)
For y = 0 To s
For x = 1 To 3
If (y * 3) + x <= r Then D(y + 1, x) = P((y * 3) + x, 1)
Next x
Next y
With Worksheets("List2")
.Columns(1).ClearContents
.Cells(1, 1).Resize(s + 1, 3).Value = D
End With
End Sub
citovat

eLCHa(26.1.2016 8:27)#029565

@elninoslov
Není až tak důležité, jak ten kód vypadá, ale jestli funguje správně.
Přijde mi zbytečné do toho tahat pole, když to excel umí zařídit sám. Možná to má smysl pouze v případě, kdy sešit obsahuje velké množství vzorců a tak tento postup vyvolá 2x překalkulování a pole 1x.
Tím, že se mi nechtělo přemýšlet jsem myslel, že bych se do toho pokusil zatáhnout evaluate - jinak by kód zůstal v podstatě stejný. Ale z popsaných důvodů mi to za to nestojí - úspora je minimální.
Pokud bych to měl dělat cyklem - což je opět pracnější - tak nějak takhle.Sub subCopy()
With Worksheets("Data")
With .Range(.Range("G5"), .Cells(.Rows.Count, 7).End(xlUp))
Dim vValues() As Variant
ReDim vValues(1 To Application.WorksheetFunction.Ceiling(.Rows.Count, 3) \ 3, 1 To 3)

Dim i As Long
For i = 1 To .Rows.Count
If Not .Cells(i) = Empty Then
vValues(1 + (i - 1) \ 3, 1 + (i + 2) Mod 3) = .Cells(i).Value
End If
Next i

End With '.Range(.Range("G5"), .Cells(.Rows.Count, 7).End(xlUp))
End With 'Worksheets("Data")

Worksheets("Copy").Cells(1).Resize(UBound(vValues, 1), 3).Cells.Value = vValues
End Subcitovat

vovka.h(26.1.2016 9:28)#029566

Když už jsem se vmísil do debaty, uvedu také svůj algoritmus, který předcházel mému vstupu do ní. Využívá toho, že Cells umí pracovat i s jedním indexem a že výstupní řazení přesně odpovídá přirozenému uložení hodnot v obdélníkové oblasti (po řádcích zleva doprava). Nepřesný počet řádků ve výstupní oblasti není na závadu (přesnější je (N - 4) \ 3) + 1); stačí, že počet řádků na výstupu je dostatečný. Vlastnost .Value pro Cells není nutné uvádět, protože pro přiřazování platí implicitně:
Sub Prenos()
Dim N As Integer, i As Integer
Dim Vstup As Range, Vystup As Range
With Sheets("List1")
N = .Cells(Rows.Count, 7).End(xlUp).Row
Set Vstup = .Range("G5:G" & N)
End With
Set Vystup = Sheets("List2").Range("A1:C" & N)
For i = 1 To N
Vystup.Cells(i) = Vstup.Cells(i)
Next i
End Sub
citovat

Strana:  1 2   další »

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse