Příspěvky uživatele
< návrat zpět
Toto máte určite zle technicky:
Sheets("Nabídka").Range(("B" & Radek), Range("B:BG" & Radek)).Copy
má to byť
Sheets("Nabídka").Range("B" & Radek & ":BG" & Radek)
a navyše ak nemajú listy rovnaké údaje na rovnakých riadkoch, tak je to zle aj logicky. Musel by ste použiť 2. cyklus. Keď jeden by bral vždy po jednom DATA a druhý cyklus by pre každý DATA riadok prešiel celú NABIDKA. To je zbytočne pomalé, preto som použil hromadný maticový MATCH/POZVYHLEDAT v Evaluate ("vyhodnocovač vzorcov").
Bola by dobrá príloha, kde by bolo vidieť, či sa jedná o rovnaké riadky, rovnaký počet riadkov, a či je vôbec potrebné kopírovať xlPasteAll, alebo by stačilo iba hodnoty. Ale je pravda, že to by som Vám zase iba skomplikoval kód :)
Oprava, zabudol som na korekciu v prípade, ak bude kontrolovaný iba 1 riadok, vtedy nevráti Evaluate pole ale iba hodnotu - opravené:
Sub Najdi_kopiruj()
Dim RadkuN As Long, RadkuD As Long, i As Long, aFind
Application.ScreenUpdating = False
RadkuD = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
If RadkuD = 1 Then MsgBox "Žádné data.", vbExclamation: Exit Sub
With Worksheets("Nabídka")
RadkuN = .Cells(Rows.Count, 1).End(xlUp).Row
If RadkuN = 1 Then MsgBox "Žádné nabídky.", vbExclamation: Exit Sub
aFind = Evaluate("=IFNA(MATCH('Data'!N2:N" & RadkuD & ",'Nabídka'!A2:A" & RadkuN & ",0),0)")
If IsArray(aFind) Then
For i = 1 To RadkuD - 1
If aFind(i, 1) > 0 Then .Range("B1:BG1").Offset(aFind(i, 1), 0).Copy Worksheets("Data").Cells(i + 1, "BY")
Next i
Else
If aFind > 0 Then .Range("B2:BG2").Copy Worksheets("Data").Cells(1, "BY")
End If
End With
Application.ScreenUpdating = True
End Sub
Neviem, či Vás chápem ... skúste iný prístup:
Sub Najdi_kopiruj()
Dim RadkuN As Long, RadkuD As Long, i As Long, aFind
Application.ScreenUpdating = False
RadkuD = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
If RadkuD = 1 Then MsgBox "Žádné data.", vbExclamation: Exit Sub
With Worksheets("Nabídka")
RadkuN = .Cells(Rows.Count, 1).End(xlUp).Row
If RadkuN = 1 Then MsgBox "Žádné nabídky.", vbExclamation: Exit Sub
aFind = Evaluate("=IFNA(MATCH('Data'!N2:N" & RadkuD & ",'Nabídka'!A2:A" & RadkuN & ",0),0)")
For i = 1 To RadkuD - 1
If aFind(i, 1) > 0 Then
.Range("B1:BG1").Offset(aFind(i, 1), 0).Copy Worksheets("Data").Cells(i + 1, "BY")
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
A priložte prílohu.
OT:
@marjankaj: Presne toto dodržiavam 
Najskôr všetky možnosti vyskúšam, preštelujem, potom googlujem, potom kontakt známych, no a potom ... potom príde manželka a spraví to 
EDIT: Inak ma napadá, ak by mali stĺpce hlavičky, a niekde by mohli byť 2 bunky s parametrom pre Rozšírený filter, tak stačí:
Sub Rozsireny_Filter()
Worksheets("List1").Range("A1:B141").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Worksheets("List1").Range("D1:D2"), CopyToRange:=Worksheets("List2").Range("A1"), Unique:=False
End Sub
Ešte sa mi za tie roky nestalo že by vo VBA mal integer či long inú default ako 0, alebo boolean po deklarácii nemal False, či nedajbože Range nemala Nothing, alebo string nemal "".
Ešte nejaký ten zdroj...
Ak sú to susedné bunky, kopírujte ich naraz obe:
Sub kopiruj()
Dim i As Integer, j As Integer
'zkopíruje A1:A140 pokud > 0
For i = 1 To 140
With Worksheets("List1").Cells(i, 2)
If .Value > 0 Then
j = j + 1
Worksheets("List2").Cells(j, 1).Resize(, 2) = .Offset(0, -1).Resize(, 2).Value
End If
End With
Next i
End Sub
A ešte rýchlejšie cez pole (ale tu sa jedná o máličko údajov, takže asi zbytočné...)
Sub kopiruj2()
Dim i As Integer, j As Integer, D(), V()
D = Worksheets("List1").Range("A1:B140").Value
'zkopíruje A1:A140 pokud > 0
For i = 1 To 140
If D(i, 2) > 0 Then
j = j + 1
ReDim Preserve V(1 To 2, 1 To j)
V(1, j) = D(i, 1): V(2, j) = D(i, 2)
End If
Next i
If j > 0 Then Worksheets("List2").Range("A1").Resize(j, 2).Value = Application.Transpose(V)
End Sub
Pr.
Pr.
Dim Seznam1()
Private Sub ComboBox1_Change()
Dim r As Long, s As Integer
s = Application.Match(ComboBox1.Value, Seznam1, 0)
r = wsSeznam.Cells(Rows.Count, s).End(xlUp).Row - 1
ComboBox2.List = wsSeznam.Cells(2, s).Resize(r).Value
ComboBox2.ListIndex = 0
End Sub
Private Sub UserForm_Initialize()
Seznam1 = Application.Transpose(wsSeznam.Range("A1:C1").Value)
ComboBox1.List = Seznam1
ComboBox1.ListIndex = 0
End Sub
??? Takže v liste "Dovolené" budú vpisovať zamestnanci dátumy do buniek C4:W16 ? Je to prichystané pre 16 zamestnancov. Ale ročný prehľad, list "2021" je iba pre 6 ľudí.
Ja by som tam prirobil ešte kontrolu na existenciu checkboxu pre každú z buniek. Bude to používať človek, tvor omylný, a ľahko môže označiť aj oblasť (trebárs skrytú), kde už checkboxy sú...
Ak je to k predošlej prílohe tak tam je "signifikantný" asi stĺpec B - Vypln2.
Ak je to niečo iné tak končí na "xxx" - Vypln3
Skúste parameter 21 namiesto 2.
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)
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é.
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.
Uživatelské menu
\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