ještě jednou moc prosím, nenašel by se někdo z místních guru, kdo by mě s tím pomohl, moc děkuji
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Tipy a triky pro Excel a makra VBA
< návrat zpět
Téma: VBA - kopírování určitých buněk
MS Excel
Téma: VBA - kopírování určitých buněk 
Zaslal/a 9.1.2017 18:30
Zdravím,
potřebuji poradit s tímto VBA.
Cca 1000 řádků a 10 sloupců dat v List1. V 11 sloupci je pouze v některých řádcích znak x. Moc bych potřeboval kod, po kterém se data ze sloupce C,D,E,F v řádcích kde je to x překopírují do List2 a potom jsou tyto řádky v List1 smazány.Mám pouze kod na to mazání:
Set Rng = Range("K2:1000")
i = 1
For counter = 1 To Rng.Rows.Count
If Rng.Cells(i) = "x" Then
i = i + 1
Else
Rng.Cells(i).EntireRow.Delete
End If
Next
End Sub
Moc díky!
Ahoj vyzkoušej tento kód (na kopii sešitu).
Sub kopiruj_a_vymaz()
Dim i As Long
Dim maxRadek As Long
Application.ScreenUpdating = False
maxRadek = List1.Cells(Rows.Count, 1).End(xlUp).Row
For i = maxRadek To 1 Step -1
If List1.Cells(i, 11).Value = "x" Then
List2.Range("A1").EntireRow.Insert
List1.Range("C" & i & ":" & "F" & i).Copy List2.Range("A1:D1")
List1.Rows(i).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub kopiruj_a_vymaz()
Dim i As Long
Dim maxRadek As Long
Application.ScreenUpdating = False
maxRadek = List1.Cells(Rows.Count, 1).End(xlUp).Row
For i = maxRadek To 1 Step -1
If List1.Cells(i, 11).Value = "x" Then
List2.Range("A1").EntireRow.Insert
List1.Range("C" & i & ":" & "F" & i).Copy List2.Range("A1:D1")
List1.Rows(i).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
WOW! Funguje parádně. Děkuji. Ještě otázka, jak by vypadal zápis, kdybych ty data potřeboval ze sloupců A,D,F,H,J?
Např:
Sub kopiruj_a_vymaz_2()
Dim i As Long
Dim maxRadek As Long
Dim Oblast As Range
Application.ScreenUpdating = False
maxRadek = List1.Cells(Rows.Count, 1).End(xlUp).Row
For i = maxRadek To 1 Step -1
Set Oblast = Union(List1.Cells(i, 1), List1.Cells(i, 4), List1.Cells(i, 6), List1.Cells(i, 8), List1.Cells(i, 10)) 'výběr buněk ve sloupcích A D F H J
If List1.Cells(i, 11).Value = "x" Then
List2.Range("A1").EntireRow.Insert
Oblast.Copy List2.Range("A1:E1")
List1.Rows(i).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub kopiruj_a_vymaz_2()
Dim i As Long
Dim maxRadek As Long
Dim Oblast As Range
Application.ScreenUpdating = False
maxRadek = List1.Cells(Rows.Count, 1).End(xlUp).Row
For i = maxRadek To 1 Step -1
Set Oblast = Union(List1.Cells(i, 1), List1.Cells(i, 4), List1.Cells(i, 6), List1.Cells(i, 8), List1.Cells(i, 10)) 'výběr buněk ve sloupcích A D F H J
If List1.Cells(i, 11).Value = "x" Then
List2.Range("A1").EntireRow.Insert
Oblast.Copy List2.Range("A1:E1")
List1.Rows(i).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
WOW!? Prečo písať script na niečo, čo zvládne rozšírený filter? Resp. prečo nepoužiť za základ scriptu v tomto prípade práve rozšírený filter?
Btw, ten kód v úvode vlákna je chybný (Range("K2:1000")) a i po oprave range určite nerobí to, čo popisuješ, že akože robí..
Btw, ten kód v úvode vlákna je chybný (Range("K2:1000")) a i po oprave range určite nerobí to, čo popisuješ, že akože robí..
@AL
Veď ani nepísal, že mu ten kód funguje. Iba ho má napísaný
Veď ani nepísal, že mu ten kód funguje. Iba ho má napísaný
@Stalker - paráda, funguje to moc krásně. Moc děkuji. Jen bych potřeboval dvě, pro vás určitě maličkosti. Potřeboval bych kopírovat jen data (bez formátování) a potom bych potřeboval "zamíchat" buňky. Jak prostě dostat sloupec A Listu1 do Listu2, ale do sloupce B. Zamíchal jsem pořadí v kodu takto, ale to je hloupost. S VBA začínám a toto je pro mě vyšší dívčí, tak se nezlobte a děkuji. 
Set Oblast = Union(List1.Cells(i, 4), List1.Cells(i, 1), List1.Cells(i, 6), List1.Cells(i, 8), List1.Cells(i, 10))
Set Oblast = Union(List1.Cells(i, 4), List1.Cells(i, 1), List1.Cells(i, 6), List1.Cells(i, 8), List1.Cells(i, 10))
Potřebuji už jen poradit, jak kopírovat pouze hodnoty buněk, bez podmínečného formátování? Pomůže prosím někdo?
S kopírováním pouze hodnot bez formátů není problém, ale k tomu prohození sloupců mě nenapadlo lepší řešení než pouze takto na "hulváta", možná se objeví znalejší s lepším postupem.
Sub kopiruj_a_vymaz_2()
Dim i As Long
Dim maxRadek As Long
Dim Oblast As Range
Application.ScreenUpdating = False
maxRadek = List1.Cells(Rows.Count, 1).End(xlUp).Row
For i = maxRadek To 1 Step -1
Set Oblast = Union(List1.Cells(i, 6), List1.Cells(i, 8), List1.Cells(i, 10)) 'výběr buněk ve sloupcích F H J
If List1.Cells(i, 11).Value = "x" Then
List2.Range("A1").EntireRow.Insert
List1.Cells(i, 1).Copy
List2.Cells(1, 2).PasteSpecial Paste:=xlPasteValues
List1.Cells(i, 4).Copy
List2.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Oblast.Copy
List2.Range("C1:E1").PasteSpecial Paste:=xlPasteValues
List1.Rows(i).EntireRow.Delete
End If
Next i
Application.CutCopyMode = False
Set Oblast = Nothing
Application.ScreenUpdating = True
End Sub
Sub kopiruj_a_vymaz_2()
Dim i As Long
Dim maxRadek As Long
Dim Oblast As Range
Application.ScreenUpdating = False
maxRadek = List1.Cells(Rows.Count, 1).End(xlUp).Row
For i = maxRadek To 1 Step -1
Set Oblast = Union(List1.Cells(i, 6), List1.Cells(i, 8), List1.Cells(i, 10)) 'výběr buněk ve sloupcích F H J
If List1.Cells(i, 11).Value = "x" Then
List2.Range("A1").EntireRow.Insert
List1.Cells(i, 1).Copy
List2.Cells(1, 2).PasteSpecial Paste:=xlPasteValues
List1.Cells(i, 4).Copy
List2.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Oblast.Copy
List2.Range("C1:E1").PasteSpecial Paste:=xlPasteValues
List1.Rows(i).EntireRow.Delete
End If
Next i
Application.CutCopyMode = False
Set Oblast = Nothing
Application.ScreenUpdating = True
End Sub
@Stalker - Moc děkuji. Mohu poprosit ještě o poslední finální verzi. Prohození sloupců jsem vyřešil jinak, změnou ve zdrojovém Listu1. Takže stačí upravit to kopírování pouze hodnot v té verzi: kopiruj_a_vymaz_2. Ještě jednou velké díky za pomoc a trpělivost.
Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články