Skúsil by som sa na to eventuálne pozrieť, pokiaľ čas dovolí. Problém ale je, že v uvedenom odkaze sa zrejme žiadny rozplneni.xlsx nenachádza. Aspoň ja ho teda v uvedenom archíve nevidím...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: Složité plnění buněk
Uzamčeno - nelze přidávat nové příspěvky.
Sub rozplnit()
Dim retezec$, znak$, kod$
Dim pocetcarek%, pocetpomlcek%, f%, delka%
Dim pocetbunek%, rdk%, slp%
''' dalsi DIM si dopln
retezec = ActiveCell.Value
delka = Len(retezec)
If delka > 0 Then
ReDim x(delka) As Integer
pocetcarek = 0 '' alespon 1 hodnota!
Else
MsgBox ("oznac bunku!")
Exit Sub
End If
pocetpomlcek = 0
'zjisteni pozic "," a "-"
For f = 1 To delka
znak = Mid(retezec, f, 1)
If znak = "," Then
pocetcarek = pocetcarek + 1
x(f) = 1
End If
If znak = "-" Then
pocetpomlcek = pocetpomlcek + 1
x(f) = 2
End If
Next f
If pocetcarek >= 0 Then
pocetbunek = pocetcarek + 1
ReDim bunka(pocetcarek + 1) As String
ReDim pozice(pocetcarek) As Integer
'''pozice carek
y = 0
For f = 1 To delka
If x(f) = 1 Then
y = y + 1
pozice(y) = f
End If
Next f
''' jednotlive bunky
For f = 1 To pocetcarek
bunka(f) = Trim(Mid(retezec, pozice(f - 1) + 1, pozice(f) - pozice(f - 1) - 1))
Next f
bunka(f) = Trim(Right(retezec, delka - pozice(f - 1) - 1))
''''''''''''''''''''''''''''''''''''''''''''''
''' rozbor bunek '''
''''''''''''''''''''''''''''''''''''''''''''''
rdk = ActiveCell.Row
slp = 2
For f = 1 To pocetbunek
kod = Trim(bunka(f))
kdejepomlcka = InStr(kod, "-")
If kdejepomlcka = 0 Then
slp = slp + 1
If slp > 14 Then slp = 3: rdk = rdk + 1
Cells(rdk, slp) = kod
Else
''' vyraz s pomlckou vzdy musi zacinat cislem!!
g = 0
Do
g = g + 1
jecislo_zleva1 = IsNumeric(Mid(kod, g, 1))
Loop While jecislo_zleva1
pocetcifer = g - 1
cislo1 = Left(kod, pocetcifer)
doplnek = Mid(kod, pocetcifer + 1, kdejepomlcka - pocetcifer - 2)
cislo2 = Mid(kod, kdejepomlcka + 2, pocetcifer)
For h = cislo1 To cislo2
slp = slp + 1
If slp > 14 Then slp = 3: rdk = rdk + 1
Cells(rdk, slp) = h & doplnek
Next h
End If
Next f
End If
End Sub
citovat
MS Excel
Téma: Složité plnění buněk 
Zaslal/a jablicko85 16.11.2011 10:00
Dobrý den, v minulém dotazu o rozepsání číselného rozmezí na jednotlivá čísla mi velice pomohl AL. Dokázal by mi prosím někdo pomoci se složitější věcí? Když mám v jedné buňce jednotlivá čísla oddělená čárkou i několik číselných rozmezí a tato čísla bych potřeboval vyplnit do předem zvolených buněk? Kdyby se to povedlo, byl bych Vám moc vděčný, posílám odkaz na soubor, jak by to mělo vypadat.
http://p-numismatika.cz/rozplneni.xlsx
Ten původní kod od AL je takto
Option Explicit
Sub vypln()
Dim Vstup As String, Zaciatok As String, Koniec As String, Kod As String
Dim Od As Long, Po As Long, j As Long, Vloz As Long
Dim Stred As Integer
Application.ScreenUpdating = False
Vstup = Range("A1")
Stred = InStr(Vstup, "-")
Zaciatok = Left(Vstup, Stred - 2)
Koniec = Right(Vstup, Len(Vstup) - Stred - 1)
Od = Val(Zaciatok)
Po = Val(Koniec)
Kod = Right(Zaciatok, Len(Zaciatok) - Len(Od))
Vloz = Od
For j = 1 To Po - Od + 1
Cells(j, 2) = Vloz & Kod
Vloz = Vloz + 1
Next j
End Sub
Uzamčeno - nelze přidávat nové příspěvky.Děkuji moc za snahu, tady jsem to pro jistotu ještě uploadnul na uloz.to
http://www.uloz.to/11089702/rozplneni-xlsxcitovat
http://www.uloz.to/11089702/rozplneni-xlsxcitovat
Tak z ulož to už som to stiahol. Dve otázky:
1. Tá vstupná oblasť sa musí skladať zo zlúčených buniek?
2. Výstupná oblasť má mať 12 stĺpcov a potrebný počet riadkov?
Toto by som potreboval potvrdiť a potom som asi schopný s tým niečo podniknúť, nebude to asi nič ťažké, ale neviem, kedy sa k tomu dostanem...citovat
1. Tá vstupná oblasť sa musí skladať zo zlúčených buniek?
2. Výstupná oblasť má mať 12 stĺpcov a potrebný počet riadkov?
Toto by som potreboval potvrdiť a potom som asi schopný s tým niečo podniknúť, nebude to asi nič ťažké, ale neviem, kedy sa k tomu dostanem...citovat
Oblast ze sloučených buněk být nemusí, jen by to bylo lepší z hlediska obsahu okolo, řádků by bylo maximálně 5citovat
(16.11.2011 16:26)#006491
Sub rozplnit()
Dim retezec$, znak$, kod$
Dim pocetcarek%, pocetpomlcek%, f%, delka%
Dim pocetbunek%, rdk%, slp%
''' dalsi DIM si dopln
retezec = ActiveCell.Value
delka = Len(retezec)
If delka > 0 Then
ReDim x(delka) As Integer
pocetcarek = 0 '' alespon 1 hodnota!
Else
MsgBox ("oznac bunku!")
Exit Sub
End If
pocetpomlcek = 0
'zjisteni pozic "," a "-"
For f = 1 To delka
znak = Mid(retezec, f, 1)
If znak = "," Then
pocetcarek = pocetcarek + 1
x(f) = 1
End If
If znak = "-" Then
pocetpomlcek = pocetpomlcek + 1
x(f) = 2
End If
Next f
If pocetcarek >= 0 Then
pocetbunek = pocetcarek + 1
ReDim bunka(pocetcarek + 1) As String
ReDim pozice(pocetcarek) As Integer
'''pozice carek
y = 0
For f = 1 To delka
If x(f) = 1 Then
y = y + 1
pozice(y) = f
End If
Next f
''' jednotlive bunky
For f = 1 To pocetcarek
bunka(f) = Trim(Mid(retezec, pozice(f - 1) + 1, pozice(f) - pozice(f - 1) - 1))
Next f
bunka(f) = Trim(Right(retezec, delka - pozice(f - 1) - 1))
''''''''''''''''''''''''''''''''''''''''''''''
''' rozbor bunek '''
''''''''''''''''''''''''''''''''''''''''''''''
rdk = ActiveCell.Row
slp = 2
For f = 1 To pocetbunek
kod = Trim(bunka(f))
kdejepomlcka = InStr(kod, "-")
If kdejepomlcka = 0 Then
slp = slp + 1
If slp > 14 Then slp = 3: rdk = rdk + 1
Cells(rdk, slp) = kod
Else
''' vyraz s pomlckou vzdy musi zacinat cislem!!
g = 0
Do
g = g + 1
jecislo_zleva1 = IsNumeric(Mid(kod, g, 1))
Loop While jecislo_zleva1
pocetcifer = g - 1
cislo1 = Left(kod, pocetcifer)
doplnek = Mid(kod, pocetcifer + 1, kdejepomlcka - pocetcifer - 2)
cislo2 = Mid(kod, kdejepomlcka + 2, pocetcifer)
For h = cislo1 To cislo2
slp = slp + 1
If slp > 14 Then slp = 3: rdk = rdk + 1
Cells(rdk, slp) = h & doplnek
Next h
End If
Next f
End If
End Sub
citovat
hokuspokus funguje, nemám co dodat, jen smeknout před genialitou a poděkovat, hodně mi to usnadní práci, děkuji oběma a přeji příjemný večer...citovat
(16.11.2011 18:51)#006493
není to geniální, určitě to lze vytvořit profesionálněji líp, ale šlo mi rychlou pomoc a hlavně.. funguje tocitovat
Omlouvám se ještě za jeden dotaz, jsem v tomto naprostý začátečník...jak bych měl kod změnit, kdybych potřeboval rozplnit jinou řadu čísel s písmenem na začátku a na konci F2325A - F2333A ?citovat
(16.11.2011 23:56)#006495
F2325A - F2333A ?... jak říká klasik "já to tušila!!!", že to bude doplňující otázka. Proto jsem tam dal tu poznámku - ''' vyraz s pomlckou vzdy musi zacinat cislem!!.. můžeš analogicky použít stejný princip jako je v kodu - tam kde je ta zmínka o doplňku.. akorát to dáš dopředu.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