MS Excel

Ahoj.

Snažím se vložit vyjmutý řádek z jednoho listu do prvního prázdného řádku na jiném listě.

Ale nějak se nedaří.

pro vkládání jsem se snažil použít toto, ale asi je něco špatně.

Prosím o pomoc, děkuji.

Sheets("Obaly").Cells(65536, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll

Zaslat odpověď >

elninoslov(4.12.2020 17:44)#049139

Mne to normálne funguje:
Sub Copy_pokus()
Sheets("pokus").Range("2:2").Copy
Sheets("Obaly").Cells(65536, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
End Sub
Office 2019 x64 SK Pro, Win 10 x64 Sk Pro v1909
Uveďte väčší kus kódu, najlepšie prílohu - súbor.citovat

Raders486(4.12.2020 17:53)#049140

Tak je špatně asi někde něco jiného.
Posílám přílohu i s procedurou, pokud by jsi se na to chtěl podívat.

Děkuji

Příloha: rar

49140_vlozit.rar (68kB, staženo 14x)

citovat

Raders486(4.12.2020 18:02)#049141

Celá procedura ze sešitu
Sub Obaly()

Application.ScreenUpdating = False

Dim radek As Integer
Dim posledni As Long
posledni = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row

Sheets("Data").Select

For radek = 1 To posledni

If Range("C" & radek).Value2 = "8100" Or Range("C" & radek).Value2 = "8200" Or Range("C" & radek).Value2 = "8300" Then
Range("C" & radek).Offset(0, -2).Range("A1:Z1").Cut
Sheets("Obaly").Cells(65536, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll

ElseIf Range("C" & radek) <> 8100 Or Range("C" & radek) <> 8200 Or Range("C" & radek) <> 8300 Then

End If

Next

Application.ScreenUpdating = True
End Subcitovat

Raders486(4.12.2020 18:45)#049142

Ještě jsem našel na webu toto, ale obávám se že je nějaký problém s formátem čísla na listě Data ve sloupci C.

S níže uvedeným by to mělo pracovat, ale nepracuje.

Sub Obaly()
Application.ScreenUpdating = False

Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("Data").Cells(Rows.Count, "C").End(xlUp).Row
lr2 = Sheets("Obaly").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
If Range("C" & r).Value2 = "8100" Or Range("C" & r).Value2 = "8200" Or Range("C" & r).Value2 = "8300" Then
Sheets("Data").Rows(lr2 + 1).EntireRow.Insert
Rows(r).Cut Destination:=Sheets("Obaly").Rows(lr2 + 1)
Rows(r).Delete
lr2 = Sheets("Obaly").Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
Application.ScreenUpdating = True
End Subcitovat

elninoslov(4.12.2020 19:18)#049143

Vyriešil by som to inak. Nie jednotlivé Cut, ale hromadné Copy.
Len si vyberte a aktivujte na konci jednu z možností:
rngCopy.ClearContents 'smaže obsah buněk
rngCopy.Clear 'smaže obsah a formátování buněk
rngCopy.EntireRow.Delete 'odstraní řádky
Celé makro Obaly2:
Sub Obaly2()
Dim Radek As Long
Dim RadkuC As Long, C()
Dim rngCopy As Range

'načíst data ze sloupce C
With Worksheets("Data")
RadkuC = .Cells(Rows.Count, 1).End(xlUp).Row - 1
Select Case RadkuC
Case 0: MsgBox "Žádné data", vbExclamation: Exit Sub
Case 1: ReDim C(1 To 1, 1 To 1): C(1, 1) = .Cells(2, "C").Value2
Case Else: C() = .Cells(2, "C").Resize(RadkuC).Value2
End Select

'proleze údaje ze sloupce C
For Radek = 1 To RadkuC
Select Case C(Radek, 1)
Case "8100", "8200", "8300" 'když je požadovaný údaj, přidej do multioblasti ke skopírování
If rngCopy Is Nothing Then Set rngCopy = .Range("A1:Z1").Offset(Radek, 0) Else Set rngCopy = Union(rngCopy, .Range("A1:Z1").Offset(Radek, 0))
Case Else
End Select
Next Radek
End With

If Not rngCopy Is Nothing Then
rngCopy.Copy Worksheets("Obaly").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 'skopíruje jednorázově všechny validní bunky
'rngCopy.ClearContents 'smaže obsah buněk
'rngCopy.Clear 'smaže obsah a formátování buněk
'rngCopy.EntireRow.Delete 'odstraní řádky
End If
End Sub
Rýchlostne to bude podstatne lepšie. Len skúste či to fachá aj u Vás. Malo by.

A doplňte si ešte pod
Case Else
čo sa má diať ak je hodnota iná ako tie vybrané. To nemáte vo svojom makre špecifikované.

Příloha: zip

49143_vytrihnout_vlozit.zip (76kB, staženo 11x)

citovat

Raders486(4.12.2020 19:54)#049144

Elninoslov děkuji.
Opět perfektní práce a šlape jak má.

Jinak pokud nenajde hledané hodnoty tak se nic neděje a procedura se ukončí po kontrole všech řádků.

Nejde mi do hlavy, kde byla chyba u mě.
Mohl by jste se na to podívat prosím?
Myslím tu prvotní proceduru, viz příloha.

Příloha: rar

49144_vlozit.rar (68kB, staženo 12x)

citovat

elninoslov(4.12.2020 20:19)#049145

Popravde nepoznám odpoveď na to, prečo PasteSpecial nefachá v tomto prípade. Každopádne ak to dáte priamo ako parameter Destination tak to ide:
Range("C" & radek).Offset(0, -2).Range("A1:Z1").Cut Sheets("Obaly").Cells(65536, 1).End(xlUp).Offset(1, 0)citovat

Raders486(5.12.2020 5:22)#049146

No jsem rád, že to není chyba mezi klávesnici a židlí, protože jsem to zkoušel různě cca 2 hodiny, ale stejně jsem na to také nedošel proč to nejde.

Ještě jednou děkuji za úpravu procedury a hlavně za ochotu.
Toto je fakt skvělý web, hlavně pro začátečníky co se chtějí něco naučit.

Myslím si, že i pokročilí si zde přijdou na své, když se nám pomalejším snaží pomoct vyřešit naše dotazy. Dost věcí si zde zopakujete a procvičíte.

Díky vám všem.citovat

Téma: Vlož vyjmutý řádek

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje