Už to mám 
Sheets("Nabídka").Range(("B" & Radek), Sheets("Nabídka").Range("BG" & Radek)).Copy
citovat
Sheets("Nabídka").Range(("B" & Radek), Sheets("Nabídka").Range("BG" & Radek)).Copy
citovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: Relativní oblast
MS Excel
Téma: Relativní oblast 
Zaslal/a Raders486 30.12.2020 16:59
Ahoj.
Potřeboval bych pomoci s relativní oblasti.
Cyklus prohledává čísla z listu "Data" ze sloupce "N" v listě "Nabídky" ve sloupci "A". Pokud číslo najde, měl by z listu "Nabídky" do listu "Data" nakopírovat všechny buňky od "B" po "BG" z řádku kde se nalezené číslo nachází.
Snažím se využít toto, ale nějak mi to nejde.
Sub Najdi_kopiruj()
Dim Radek As Integer
Dim posledni As Long
posledni = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
For Radek = 1 To posledni
If Sheets("Data").Range("N" & Radek).Value2 = Sheets("Nabídka").Range("A" & Radek).Value2 Then
Sheets("Nabídka").Range(("B" & Radek), Range("B:BG" & Radek)).Copy
Sheets("Data").Range("BY" & Radek).PasteSpecial xlPasteAll
End If
Next
End Sub
Mohl by mi prosím někdo pomoci? Měla by to být prkotina, ale nějak mi to prostě nejde.
Vzhledem k citlivosti dat, pošlu když tak přílohu do PM.
Děkuji za ochotu a přeji pěkný zbytek svátků.
Problém je v tom, že se procedura zastaví v okamžiku když se čísla v listě "Data" ve sloupci "N" shodují. Opět nechápu proč když mám zadáno, že má projít celý list.
Potřeboval bych, aby projela všechny řádky a je jedno jestli jsou čísla ve sloupci "N" stejná.
Prostě když je číslo stejné tak budou i stejné nakopírované hodnoty.citovat
Potřeboval bych, aby projela všechny řádky a je jedno jestli jsou čísla ve sloupci "N" stejná.
Prostě když je číslo stejné tak budou i stejné nakopírované hodnoty.citovat
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.
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.
Příloha: 
49298_najdi_kopiruj.zip (20kB, staženo 9x)
citovat49298_najdi_kopiruj.zip (20kB, staženo 9x)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
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
Příloha: 49299_najdi_kopiruj.zip (18kB, staženo 8x)
citovat49299_najdi_kopiruj.zip (18kB, staženo 8x)Elninoslov jako vždy jste pochopil správně a kód pracuje na jedničku. Děkuji.
Spíše nechápu proč se mi to zastavilo v okamžiku, když se čísla ve sloupci N shodovala s předešlým řádkem.
Mohl by jste mi objasnit příčinu?
Teď to prosím neberte tak, že bych si chtěl něco vymýšlet a podobně, jsem rád za každou pomoc.
Jde o to, že Vaše kódy jsou pro mě jako začátečníka jednou velkou neznámou a tak by mi hodně pomohlo, pokud by jste mohl provést nápravu v mém kódu, ve kterém se orientuji mnohem lépe.
Jinak děkuji i tak.citovat
Spíše nechápu proč se mi to zastavilo v okamžiku, když se čísla ve sloupci N shodovala s předešlým řádkem.
Mohl by jste mi objasnit příčinu?
Teď to prosím neberte tak, že bych si chtěl něco vymýšlet a podobně, jsem rád za každou pomoc.
Jde o to, že Vaše kódy jsou pro mě jako začátečníka jednou velkou neznámou a tak by mi hodně pomohlo, pokud by jste mohl provést nápravu v mém kódu, ve kterém se orientuji mnohem lépe.
Jinak děkuji i tak.citovat
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 :)citovat
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 :)citovat
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