MS Excel

Téma: Podmínka pro rozplnění buněk

Zaslal/a jablicko85 27.2.2013 14:42

Dobrý den,

potřeboval bych trošišku pomoct s jednou podmínkou při použití tohoto makra pro rozplnění buněk, potřeboval bych, aby když bunka, z níž že rozplňuje obsahuje spojení "M-číslo" místo "číslo" je nějaké číslo či písmeno to nebralo jako rozmezí od - do, ale jako samostatnou jednotku, která se rozplní do jedné buňky např M-1011P

Děkuji moc

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 = 14
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

Zaslat odpověď >

Nebyly zaslány žádné odpovědi.

Uživatelské menu

Nejste přihlášen(a)

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.