• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

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.

---

Strana:  « předchozí  1 2

hokuspokus(17.11.2011 0:49)#006496

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
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 nemusi zacinat cislem!!
''' mohou byt 4 verze: 1234 - 1234A - A1234 - A1234B !!
''' nejdrive najdu pozici prvni cifry
g = 0
Do
g = g + 1
jecislo = IsNumeric(Mid(kod, g, 1))
Loop Until jecislo

doplnek1 = vbNullString
doplnek2 = vbNullString
If g > 1 Then doplnek1 = Left(kod, g - 1)

gg = g
Do
gg = gg + 1
jedalsicifra = IsNumeric(Mid(kod, gg, 1))
Loop While jedalsicifra

pocetcifer = gg - g

cislo1 = Mid(kod, g, pocetcifer)
doplnek2 = Mid(kod, gg, kdejepomlcka - gg - 1)
cislo2 = Mid(kod, kdejepomlcka + g + 1, pocetcifer)

For h = cislo1 To cislo2
slp = slp + 1
If slp > 14 Then slp = 3: rdk = rdk + 1
Cells(rdk, slp) = doplnek1 & h & doplnek2
Next h

End If
Next f

End If

End Sub
citovat

jablicko85(17.11.2011 13:38)#006500

Paráda, já to zkoušel měnit a už vidím, kde jsem dělal chybu:)citovat

AL(17.11.2011 23:01)#006505

jablicko, než som sa k tomu dostal, tak hokuspokus to poriešil, som rád, že Ti to helflocitovat

Strana:  « předchozí  1 2

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse