< návrat zpět
MS Excel
Téma: VBA - kopírování určitých buněk 
Zaslal/a TLOU 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!
Stalker(10.1.2017 22:10)#034428 
Takto?
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").PasteSpecial Paste:=xlPasteValues
List1.Rows(i).EntireRow.Delete
End If
Next i
Application.CutCopyMode = False
Set Oblast = Nothing
Application.ScreenUpdating = True
End SubcitovatLugr(14.4.2019 21:31)#043151 
Dobrý den,
nevím co dělám špatně, ale mě to nefunguje.
Potřeboval bych zkopírovat dokončené a potom odstranit řádky("Dokončeno").
a ještě bych potřeboval kdyby do tabulky "Tabulka38" přibylo dalších 10 nových řádků.
Příloha: 
43151_pokus.zip (26kB, staženo 19x) citovat
Použil som polia, je to rýchle. Listy si rovno pomenujte vo VBA. V položke "Name" im dajte wsPoruchy a wsArchiv. Uchováva to zdrojovú tbl stále 10 riadkovú.
Sub kopiruj_a_vymaz()
Dim Radku As Long, Pocet As Long, LO As ListObject, PoleS(), PoleN(), i As Long, y As Long, x As Long, RNG As Range
Set LO = wsPoruchy.ListObjects("Tabulka38")
With LO.DataBodyRange
Pocet = WorksheetFunction.CountIf(.Columns(11), "Dokončeno") 'Zisti počet Dokončeno
If Pocet = 0 Then Exit Sub
ReDim PoleN(1 To Pocet, 1 To 11) 'Priprav veľkost poľa pre prenášané dáta podľa počtu Dokončeno
PoleS = .Value 'Načítaj dáta z Tabulka38
y = Pocet 'Index riadku od spodu
For i = 1 To UBound(PoleS, 1)
If PoleS(i, 11) = "Dokončeno" Then 'Hľadaj Dokončeno
For x = 1 To 11
PoleN(y, x) = PoleS(i, x) 'Prekopíruj dáta do nového poľa
Next x
y = y - 1 'Index o riadok vyššie
If RNG Is Nothing Then Set RNG = .Rows(i) Else Set RNG = Union(RNG, .Rows(i)) 'Pridaj do oblasti na zmazanie
End If
Next i
If Not RNG Is Nothing Then 'Ak je nejaká oblasť na zmazanie
Application.ScreenUpdating = False
If .Rows.Count - Pocet < 10 Then LO.Resize LO.Range.Resize(11 + Pocet) 'Ak bude po zmazaní menší počet riadkov v Tabulka38 ako 10, tak zväčši Tabulka38
RNG.Delete Shift:=xlUp 'Odstráň riadky
Set LO = wsArchiv.ListObjects("Tabulka2")
LO.DataBodyRange.Rows(1).Resize(Pocet).Insert 'Vlož potrebný počet riadkov do archívnej tabuľky hore
LO.DataBodyRange.Rows(1).Resize(Pocet).Value = PoleN 'Archivuj data
Application.ScreenUpdating = True
End If
End With
End SubPříloha: 43154_archivuj.zip (24kB, staženo 29x) citovat
\n
RSS nejnovější články