< návrat zpět

MS Excel

Téma: posunutie riadkov rss

Zaslal/a Lubo2 6.9.2020 0:24

Dobry den ,

potreboval by som surne upravt tabulku aby sa posunula cca o 9 riadkov nizsie. Vedel by mi s tym niekto pomoct? Skusam to ale nedari sa mi to upravit kedze tato tabulka bola robena na mieru.

Sub zobrkalen()
Application.ScreenUpdating = False
If Sheets("Kalendár").Visible = False Then
Sheets("Kalendár").Visible = True
Sheets("Kalendár").Select
Else
Sheets("Kalendár").Visible = False
Sheets("Menu").Select
End If

Application.ScreenUpdating = True
End Sub

Sub kalendar()
Application.ScreenUpdating = False

Dim rng1 As Range
Set rng1 = Sheets("Kalendár").Range("B4:H4, B6:H6, B8:H8, B10:H10, B12:H12, B14:H14")
Dim kk1, kk2 As Boolean
Dim trange As Range
KA = Sheets("Kalendár").Range("O2").value - Sheets("Kalendár").Range("N2").value + 1

fff = MsgBox("Chcete prepísať všetky dáta v tabuľke B?", vbYesNo)
If fff = vbYes Then
Worksheets("tabulka B").Select
'LastRow = Sheets("tabulka B").Range("B" & Rows.Count).End(xlUp).Row
LastRow = Sheets("tabulka B").Range("A" & Rows.Count).End(xlUp).Row
'Worksheets("tabulka B").Range(Cells(3, 2), Cells(LastRow, 30)).ClearContents
Worksheets("tabulka B").Range(Cells(3, 1), Cells(100, 30)).ClearContents
End If

Worksheets("tabulka B").Range("A4") = "Hárok"
Worksheets("tabulka B").Range("B4") = "Deň"
Worksheets("tabulka B").Range("C4") = "XX"
Dim a1, b1, c1 As Long
a1 = 0
b1 = 0
c1 = 0
Dim shtgo As Boolean
shtgo = False
Dim pravda, pravda2 As Boolean

For Each cell In rng1
nr = Format(cell, "d")
nr2 = Format(cell & ".", "d")

If cell.DisplayFormat.Interior.Color = 16777215 Then
a1 = a1 + 1
b1 = b1 + 1
shtgo = False

For Each sht In Worksheets
If sht.Name = nr Then
sht.Select
Call Nahodne_Rozloz
shtgo = True
End If
Next sht

If shtgo = False Then

startt2:

Worksheets("tabulka B").Select
LastRow2 = Sheets("tabulka B").Range("B" & Rows.Count).End(xlUp).Row
Worksheets("tabulka B").Cells(LastRow2 + 1, 2).Select
ActiveCell = nr

For dd = 1 To KA
ActiveCell.Offset(0, dd) = " "
Next dd
ActiveCell.Offset(0, -1) = "x"

End If
End If

ciaobella2:

If cell.DisplayFormat.Interior.Color = 255 Then
a1 = a1 + 1
c1 = c1 + 1

shtgo = False

For Each sht In Worksheets
If sht.Name = nr Then
sht.Select
Call Nahodne_Rozloz
shtgo = True
End If
Next sht


pravda = False
Worksheets("tabulka B").Select
LastRow2 = Sheets("tabulka B").Range("B" & Rows.Count).End(xlUp).Row
Worksheets("tabulka B").Range(Cells(5, 2), Cells(LastRow2, 2)).Select
For Each cell2 In Selection
If cell2 Like nr Or cell2 Like nr2 Then
pravda = True
End If
Next cell2

startt:


Worksheets("tabulka B").Select

kk1 = False
Set trange = Worksheets("tabulka B").Range(Cells(5, 2), Cells(100, 2))
For Each cell44 In trange
If cell44 = CLng(nr) Then
For dd = 1 To KA
cell44.Offset(0, dd).value = "Closed"
Next dd
kk1 = True
End If
Next cell44

If kk1 = False Then
LastRow2 = Sheets("tabulka B").Range("B" & Rows.Count).End(xlUp).Row
Worksheets("tabulka B").Cells(LastRow2 + 1, 2).Select
ActiveCell = nr

For dd = 1 To KA
ActiveCell.Offset(0, dd) = "Closed"
Next dd
ActiveCell.Offset(0, -1) = "Closed"
End If

End If

ciaobella:

Next cell

Worksheets("tabulka B").Select

Rows("4:4").Select
Selection.AutoFilter
Range("A4").Select
ActiveWorkbook.Worksheets("tabulka B").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("tabulka B").AutoFilter.Sort.SortFields.Add Key:= _
Range("A4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("tabulka B").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("4:4").Select
Range("A4").Activate
Selection.AutoFilter
Range("A4").Select

LastRow2 = Sheets("tabulka B").Range("B" & Rows.Count).End(xlUp).Row
LastColumn = Sheets("tabulka B").Cells(4, Columns.Count).End(xlToLeft).Column

Range(Cells(LastRow2 + 1, 2), Cells(LastRow2 + 1, 2).End(xlDown)).Select
Selection.EntireRow.Select

With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Range(Cells(1, LastColumn + 1), Cells(1, LastColumn + 1).End(xlToRight)).Select
Selection.EntireColumn.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Range(Cells(4, 2), Cells(4, LastColumn)).Select
Selection.NumberFormat = "0"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With

Range(Cells(4, 2), Cells(LastRow2, 2)).Select
Selection.NumberFormat = "0"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With


Range(Cells(4, 2), Cells(LastRow2, LastColumn)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

Worksheets("tabulka B").Range("C2") = a1
Worksheets("tabulka B").Range("D2") = b1
Worksheets("tabulka B").Range("E2") = c1

Application.ScreenUpdating = True
End Sub

Sub Nahodne_Rozloz()
Dim Tovar(), Rozlozene(), i As Long, s As Long, RA As Long, Dni As Byte, Poz As Byte

LastRow = Sheets("tabulka B").Range("C" & Rows.Count).End(xlUp).Row
LastRow = LastRow - 2
LastRow2 = Sheets("tabulka B").Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False
With Worksheets("tabulka B")
s = .Cells(4, Columns.Count).End(xlToLeft).Column - 2
End With

den = ActiveSheet.Name

Worksheets("tabulka B").Select
Dim trange, mrange As Range
Set trange = Worksheets("tabulka B").Cells(3, 3).Offset(LastRow, -2).Resize(31)
Worksheets("tabulka B").Range(Cells(5, 1), Cells(LastRow2, 1)).Select

Dim pravda As Boolean
pravda = False
For Each cell In Selection
If cell Like den Then
pravda = True
End If
Next cell

If pravda = True Then
fff = MsgBox("V tabuľke sa už nachádzajú dáta zo dňa " & den & ". Chcete dáta prepísať?", vbYesNo)
If fff = vbNo Then
Exit Sub
End If

If fff = vbYes Then
startt:
For Each cell In Selection
If cell Like den Then
cell.EntireRow.Delete
GoTo startt
End If
Next cell
End If
End If

LastRow = Sheets("tabulka B").Range("C" & Rows.Count).End(xlUp).Row
LastRow = LastRow - 2
LastRow2 = Sheets("tabulka B").Range("B" & Rows.Count).End(xlUp).Row

Sheets(den).Select
With ActiveSheet

' RA = .Cells(Rows.Count, 3).End(xlUp).Row - 97

MA = Sheets("Kalendár").Range("N2").value
RA = Sheets("Kalendár").Range("O2").value - Sheets("Kalendár").Range("N2").value + 1
' MsgBox RA
If RA < 1 Then MsgBox "Žiadny názov tovaru", vbExclamation: GoTo KONIEC
' Tovar = .Cells(26, 3).Resize(RA, 7).value
Tovar = .Cells(MA, 3).Resize(RA, 7).value
Dni = .Cells(7, 4).value
End With


Randomize
ReDim Rozlozene(1 To 31, 1 To RA)
For s = 1 To RA
For i = 1 To Int((Tovar(s, 7) + 0.025) / 0.05)
Poz = Int(Rnd() * Dni) + 1
Rozlozene(Poz, s) = Rozlozene(Poz, s) + 0.05
' Rozlozene(Poz, 1).Offset(Poz, -1) = den
Next i
Next s

Worksheets("tabulka B").Select

With Worksheets("tabulka B").Cells(3, 3).Resize(, RA)
.Formula = "=SUM(C5:C350)"
.Interior.Color = 11389944
With .Offset(LastRow, 0)
' .value = Application.Transpose(Application.Index(Tovar, 0, 1))
' .Interior.Color = 12566463
' .Resize(32).Borders.LineStyle = 1
' .Offset(1, 0).Resize(31).value = Rozlozene
.Resize(31).value = Rozlozene
End With

.Parent.Activate
End With

Dim rrrng As Range
Set rrrng = Worksheets("tabulka B").Cells(4, 3).Resize(, RA)

nn = MA
For Each cell In rrrng
If Worksheets(den).Range("C" & nn) <> "" Then
cell.value = Worksheets(den).Range("C" & nn).value
End If
nn = nn + 1
Next cell




Dim pl As Boolean
pl = False

For Each cell In trange
pl = False
For tt = 1 To 16
If cell.Offset(0, tt) <> "" Then
pl = True
End If
Next tt

If pl = True Then
cell.value = den
End If
Next cell

Worksheets("tabulka B").Select

Rows("4:4").Select
Selection.AutoFilter
Range("A4").Select
ActiveWorkbook.Worksheets("tabulka B").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("tabulka B").AutoFilter.Sort.SortFields.Add Key:= _
Range("A4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("tabulka B").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("4:4").Select
Range("A4").Activate
Selection.AutoFilter
Range("A4").Select
LastRow2 = Sheets("tabulka B").Range("B" & Rows.Count).End(xlUp).Row
LastColumn = Sheets("tabulka B").Cells(4, Columns.Count).End(xlToLeft).Column

Set trange = Worksheets("tabulka B").Range(Cells(5, 2), Cells(100, 2))

trange.ClearContents

For Each cell In trange
If cell = "" And cell.Offset(0, -1) <> "" And cell.Row = 5 Then
cell.value = 1
' Exit For
End If

If cell = "" And cell.Offset(0, -1) <> "" And cell.Row > 5 Then
nunu = cell.Offset(-1, 0)
cell.value = nunu + 1
' Exit For
End If
Next cell

Range(Cells(LastRow2 + 1, 2), Cells(LastRow2 + 1, 2).End(xlDown)).Select
Selection.EntireRow.Select

With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Range(Cells(1, LastColumn + 1), Cells(1, LastColumn + 1).End(xlToRight)).Select
Selection.EntireColumn.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone



Range(Cells(4, 2), Cells(4, LastColumn)).Select
Selection.NumberFormat = "0"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With

Range(Cells(4, 2), Cells(LastRow2, 2)).Select
Selection.NumberFormat = "0"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With


Range(Cells(4, 2), Cells(LastRow2, LastColumn)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

KONIEC:
Application.ScreenUpdating = True
End Sub

Zaslat odpověď >
elninoslov(6.9.2020 0:47)#047891
elninoslov
No takto, zaregistrujte sa, a priložte prílohu - súbor. Citlivé dáta zamente, a nechajte len zopár. Hlavne ide o ponechanie rozmiestnenia všetkého. Aj kód sa bude v súbore ľahšie lúštiť s tabulátormi, ako takto bez nich.citovat
loksik.lubos(6.9.2020 16:41)#047895
avatar
priloha. potrebujem posunut celu tabulku B cca o 8riadkov nizsie.Dakujem
Příloha: rar47895_vyuctovanie-zmena-verzia-10.rar (373kB, staženo 22x)
citovat
elninoslov(8.9.2020 11:53)#047911
elninoslov
Tam treba pomeniť makrá dosť výrazne. Priložte ešte, ako má ten list "Tabulka B" vyzerať po úprave. Nieje mi jasné čo sa má posunúť. Či aj to "Kal.dni: Otvorené: Zatvorené:
", alebo až ten =SUM(C5:C350)..., alebo až "Deň Vodka Borovička Koniferka..."citovat
Lubo2(8.9.2020 15:28)#047914
avatar
Potrebujem to posunut cele od toho ako zacinaju tie nazvy riadok 4 a celu tu tabulku mozme posunut o 10 riadkov nizsie. Potrebujem donit este daje údaje a pod tabulku nemozem vkladaťcitovat
elninoslov(9.9.2020 10:50)#047916
elninoslov
Moje nervy. Celé zle! Teraz vás nekritizujem, pretože to asi neovládate, ja tiež neviem opraviť auto a mnoho ďalších vecí, ale v tom makre je dobrý asi len ten kúsok na rozloženie množstva, čo som robil kedysi tuším ja. Ten malý cyklus s poľom Rozlozene. 1
Všetko ostatné:
-nezmyselné rozsahy, raz po r. 100, potom 350, potom 42, a pritom je dní max 31, a počet alkoholu poznáte, teda x*31, alebo jedno xlUp
-priraďovanie premenných bez rozmyslu a bez správnej deklarácie. Nie toto nedeklaruje 2 premenné boolean:
Dim kk1, kk2 As Boolean
-zmätočné prepínanie medzi listami
-netuším prečo sa raz zisťuje počet riadkov v A, potom B, potom C, v tom istom liste
-neustále prepočítavanie počtu riadkov ich umiestnenia, neprišiel som na dôvod, navyše zistíte počet a aj tak vymažete riadok 5:100, načo potom ten počet?
-zmažete trange, a hneď pod tým kontrolujete či sa bunky v nej = ""
-kontrola buniek po jednej v cykloch, a zlých cykloch, keď kontroluje ďalej aj po nájdení.
-z názvov premenných nieje nijako priekazné, čo by mohli znamenať.
-chaotické vypĺňanie hotovej tabuľky
-nechápem čo znamenajú niektoré vstupné hodnoty, nedokázal som identifikovať prvotný význam, čo robia s makrom vidím.
-makro je absolútne neprehľadné - postráda tabulátory a zarovnania úrovní
-nieje tam jediný popis, čo by mala daná časť kódu robiť
-dlhé jednoprocedúrové makrá nikdy nebudú tak čitateľné ako parametrizované (to ešte neviem, či sa u Vás bude dať, toľko som to neanalyzoval)
-zbytočné cykly, napr. kontrola rozloženia, či boli rozložené nejaké údaje. Za jedno by sa nemusel alkohol vôbec vypisovať ak nebolo nič predané/rozložené, a za druhé ak už áno poznáme COUNT, COUNTA, COUNTIF, SUM, ...
a navyše
For tt = 1 To 16
? tam ich môže byť predsa viac.
-divné preformátovávanie
-načo slúži hodnota v D7 v listoch 1,2,...? Počet dní to nebude lebo síce 8-9.7 sú 2 dni, ale 1-7.7 nieje 8 dní.

To makro treba celé nie prekovať, ale znovu vytvoriť.
Celému tomu ale vôbec nerozumiem, čo to má ako robiť, prečo a za akých podmienok, ani čo má byť výsledkom. A to si nemyslím, že som v makrách nechápavý 5

Zatiaľ som sa pokúsil odchytať všemožné posuny, ale stále mi to nefachá tak ako by malo. V tom guláši mi niekde ešte niečo uniká. Uvažujem, či nieje menej času zabitého náhodou vytvorení úplne nového, ako hľadanie súvislostí a záludností v tomto. Každopádne mi dochádza trpezlivosť i čas. Takže zatiaľ Vám sem nič nedám, uvidíme večer ...
Ale nečudujte sa, že už len podľa toho, že sem tento súbor predkladáte aspoň po 5. krát, tak je jasné, že sa do toho komplikovaného gulášu nikomu asi moc nechce.

EDIT:
If cell2 Like nr Or cell2 Like nr2 Then
pravda = True
End If
A "pravda" sa už ďalej nespracováva. Takže na Pravde Vám už nezáleží ? 5 5 5citovat
marjankaj(9.9.2020 11:01)#047917
avatar

elninoslov napsal/a:

...... A to si nemyslím, že som v makrách nechápavý

To tu ešte nebolo.... elninoslov niečo nechápe. 2citovat
elninoslov(9.9.2020 11:18)#047918
elninoslov
Prisahám, že nerozumiem funkčnosti celého súboru. Ale terazky už mi fakt dochádza čas ... prchám.citovat
Lubo2(9.9.2020 20:39)#047928
avatar
pan elninoslav Zatial vam aspom velmi pekne dakujem ze ste si nasli cas na mna aj ked sa moc nerozumiem tomu tak mi to robil jeden pan. Ta hodnota D7 sluzi na to kolko dni ma rozratat do nahodnych cisel. Neviem ci sa ta tabulka neda vyriesit tak aby mohol zapisovat trebas udaje od riadku 50 lebo momentalne to funguje ze vyhlada poslednu hodnotu v tabulke a tam spravi zapis. Kedze je to cele nad vase sili budem musiet s tym asi pockat a nechat to urobit panovi co mi to robil . Ale aj tak vam velmi pekne dakujem za ochotu ze ste sa mi na to pozreli.citovat
marjankaj(9.9.2020 23:43)#047929
avatar

Lubo2 napsal/a:

pan elninoslav ..... Kedze je to cele nad vase sili budem musiet s tym asi pockat a nechat to urobit panovi co mi to robil .

To nie je iba nad sily elninoslov. Nad moje sily bolo už len čítať prvý príspevok. Niečo také sa len tak nevidí. A to naznačilo s kým máme do činenia a tak som k tomu aj pristupoval. Skrátka som na to hodil bobka. 6citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

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.

On-line nástroje