Ahoj díky moc, setřídění vyřeším tedy jinak ...
Narazil jsem na další potřebnou úpravu makra. Vím že jsem to měl napsat už na začátku, ale to jsem to bohužel ještě netušil ... :-/
Potřeboval bych upravit makro tak abych z listu "Data" kopíroval sloupce A,B a D do A, B a C.
Zkoušel jsem to upravovat sám, ale beznadějně tak bych si rád nechal poradit ... :-/
Excel VBA - překopírování dat Vyřešeno
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
- Přílohy
-
- akce.xlsm
- (18.6 KiB) Staženo 14 x
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
Upravena procedura vcetne drive pozadovaneho setrideni na listu Akce:
PS: vsadil jsem boty, ze to neni posledni pozadavek na upravu, tak se snaz
Kód: Vybrat vše
Option Explicit
Sub CopyData()
Dim SBlk As Range, SCll As Range, OfsR As Integer
Dim Cpy1 As Boolean, Cpy2 As Boolean
Dim TBlk As Range, TCll As Range, NCll As Range
With Worksheets("data") ' zdrojovy blok
Set SBlk = .Range("b2:b" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
' pro kazdou bunku zdroje prohledat sloupec B:B na akce
With SBlk
OfsR = .Rows.Count - 1 ' ofset posledniho radku zdrojoveho bloku
Set SBlk = .Resize(1, 1) ' modifikovany zdrojovy blok
End With
Do While OfsR >= 0 ' smycka prochazi zdrojovy sloupec
Set SCll = SBlk.Offset(OfsR, 0) ' zdrojova bunka
With Worksheets("akce") ' cilovy blok
Set TBlk = .Range("b6:b" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
Cpy1 = True: Cpy2 = False
For Each TCll In TBlk.Cells ' prohledat cilovy blok
' podminky - shoda pro sloupce B:B. v J:J <>4
If TCll.Value = SCll.Value And TCll.Offset(0, 8).Value <> 4 Then Cpy1 = False
' podminky - shoda pro sloupce B:B. v J:J =4
If TCll.Value = SCll.Value And TCll.Offset(0, 8).Value = 4 Then Cpy2 = True
Next TCll
If (Cpy1 And Not Cpy2) Or (Cpy1 And Cpy2) Then
' prvni volny radek na akce
With Worksheets("akce")
Set NCll = .Cells(Rows.Count, "b").End(xlUp).Offset(1, 0)
End With
' kopirovat data
NCll.Offset(0, -1).Value = SCll.Offset(0, -1).Value ' ze sloupce A do A
NCll.Value = SCll.Value ' ze sloupce B do B
' kopirovat format z A:B
SCll.Resize(1, 2).Offset(0, -1).Copy
NCll.Offset(0, -1).PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
' kopirovat data ze sloupce E do C
NCll.Offset(0, 1).Value = SCll.Offset(0, 2).Value
' kopirovat format z E
SCll.Resize(1, 1).Offset(0, 2).Copy
NCll.Offset(0, 1).PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
End If
OfsR = OfsR - 1
Loop
' setridit zaznamy na listu akce
With Worksheets("akce") ' cilovy blok
Set TBlk = .Range("a6:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
TBlk.Resize(TBlk.Rows.Count, 10).Sort Key1:=Range("A6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Set NCll = Nothing
Set SBlk = Nothing
Set SCll = Nothing
Set TBlk = Nothing
Set TCll = Nothing
End Sub
PS: vsadil jsem boty, ze to neni posledni pozadavek na upravu, tak se snaz
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
Ahoj, díky moc za makro, zatím vše funguje jak má ... Já doufám že už to byl poslední požadavek, ale kdo ví ještě uvidíme ...
Naposledy upravil(a) Branscombe dne 09 črc 2010 10:45, celkem upraveno 1 x.
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
No tak aby jsi neprohrál sázku a nemusel chodit bos, tak bych potřeboval buď doplnit předchozí makro nebo zapsat nové, nevím co je lepší a výhodnější.
Potřeboval bych překopírovat buňky z listu "Akce" na list "Data", pouze z řádků kde ve sloupci "G" je cokoliv napsáno. Buňky ze sloupce z A do F, z B do I, z C do G, z G do J a do sloupce H vložit vzorec (třeba =A1; vzorec si pak upravím)
vzorový příklad v příloze
Díky moc předem za námahu
Potřeboval bych překopírovat buňky z listu "Akce" na list "Data", pouze z řádků kde ve sloupci "G" je cokoliv napsáno. Buňky ze sloupce z A do F, z B do I, z C do G, z G do J a do sloupce H vložit vzorec (třeba =A1; vzorec si pak upravím)
vzorový příklad v příloze
Díky moc předem za námahu
- Přílohy
-
- akce.xlsm
- (19.06 KiB) Staženo 11 x
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
Jsem rad, ze mi zustanou boty, neb za poskytovane rady si nove nekoupim
Nize je samostatna procedura, ktera z listu akce prenese na list data obsah zadanych bunek (nejsou osetreny pripadne kolizni stavy v dusledku nekorektniho postupu uzivatele):
PS.: Vzhledem k tomu, ze pozadovane procedury jsou na jedno brdo, je nacase se pokusit napsat obdobne procedury sam, jinak vskutku budes s kazdou malickosti chodit na poradnu, tim nechci rict, ze se nemas ptat vubec.
Nize je samostatna procedura, ktera z listu akce prenese na list data obsah zadanych bunek (nejsou osetreny pripadne kolizni stavy v dusledku nekorektniho postupu uzivatele):
Kód: Vybrat vše
Sub CopyDataAkceToData()
Dim SBlk As Range, SCll As Range
Dim TCll As Range, TOfsR As Long
With Worksheets("akce") ' zdrojovy blok
Set SBlk = .Range("a6:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
Set TCll = Worksheets("data").Range("f2")
' prochazet ve smycce list akce a kopirovat prislusne sloupce
TOfsR = 0
For Each SCll In SBlk.Cells
If SCll.Offset(0, 6).Value <> vbNullString Then
With TCll
.Offset(TOfsR, 0).Value = SCll.Offset(0, 0).Value
.Offset(TOfsR, 3).Value = SCll.Offset(0, 1).Value
.Offset(TOfsR, 1).Value = SCll.Offset(0, 2).Value
.Offset(TOfsR, 4).Value = SCll.Offset(0, 6).Value
.Offset(TOfsR, 2).Formula = "=A1"
TOfsR = TOfsR + 1
End With
End If
Next SCll
Set TCll = Nothing
Set SCll = Nothing
Set SBlk = Nothing
End Sub
PS.: Vzhledem k tomu, ze pozadovane procedury jsou na jedno brdo, je nacase se pokusit napsat obdobne procedury sam, jinak vskutku budes s kazdou malickosti chodit na poradnu, tim nechci rict, ze se nemas ptat vubec.
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat Vyřešeno
Ahoj, díky moc ... máš samozřejmě pravdu, nebylo by od věci pokusit se napsat si to sám, ale zkoušel jsem předělat první proceduru a jak je vidět tak jsem to dělal moc složitě... :-/
PS: Ani raděj nebudu uvádět jak dlouho jsem to zkoušel předělat - byla by to ostuda
PS: Ani raděj nebudu uvádět jak dlouho jsem to zkoušel předělat - byla by to ostuda
-
- Mohlo by vás zajímat
- Odpovědi
- Zobrazení
- Poslední příspěvek
-
- 16
- 6707
-
od mirekol
Zobrazit poslední příspěvek
20 říj 2023 08:31
-
- 5
- 2766
-
od mmmartin
Zobrazit poslední příspěvek
13 črc 2023 18:44
-
- 2
- 1975
-
od honzzicek
Zobrazit poslední příspěvek
01 črc 2023 08:57
-
-
Excel komparacedvou soborů Příloha(y)
od teichmann.ondrej » 15 dub 2024 17:26 » v Kancelářské balíky - 11
- 3499
-
od teichmann.ondrej
Zobrazit poslední příspěvek
22 dub 2024 15:45
-
-
- 1
- 613
-
od Grimm
Zobrazit poslední příspěvek
12 bře 2024 21:43
Kdo je online
Uživatelé prohlížející si toto fórum: elninoslov a 6 hostů