MS Excel

Zdravím,
chtěl bych se zeptat zda by makrem šlo následující:
Ve formuláři mám vyplněné řádky mezi kterými můžou být i řádky nevyplněné. Potřeboval bych, aby se veškeré vyplněné řádky posunuly na horu na místo těch prázdných. Nelze to však řešit skrytím prázdných řádků ani jejich odstraněním. Poradí někdo makro, které by takto dokázalo zredukovat formulář? Díky

Zaslat odpověď >

Strana: 1 2 další »

cmuch(28.1.2014 19:07)#017548

Vlož do modulu listu

Sub PosunRadkyDoPrazdnych()

Dim rowempty As Boolean
Dim emptyrow As Integer, radek As Integer

Application.ScreenUpdating = False

rowempty = False

For radek = 6 To Cells(Rows.Count, "B").End(xlUp).Row

If IsEmpty(Cells(radek, 2)) And rowempty = False Then
emptyrow = radek
rowempty = True
End If

If rowempty = True And Not Cells(radek, 2) = "" Then
Range("A" & emptyrow & ":K" & emptyrow).Value = Range("A" & radek & ":K" & radek).Value
Range("A" & radek & ":K" & radek).Value = ""
rowempty = False
radek = emptyrow
End If
Next radek
Application.ScreenUpdating = True
End Subcitovat

Martin12345678(28.1.2014 20:22)#017554

Díky, avšak toto makro vyřeší pouze jeden volný řádek. Pokud mám ve formuláři 4 prázdné, tak je to ignoruje.
Nedokážu předem říci, kolik řádků bude mezi obsazenými prázdných. Šlo by makro nějak univerzálně přizpůsobit?
Jinak je to super.citovat

cmuch(29.1.2014 6:00)#017564

Tento řádek
If IsEmpty(Cells(radek, 2)) And rowempty = False Then
nahradit tímto
If Cells(radek, 2) = "" And rowempty = False Thencitovat

Martin12345678(29.1.2014 7:21)#017567

Díky:-)citovat

eLCHa(29.1.2014 7:32)#017569

Když už jsem to dělal ;)

Minimalizace přístupů na list = rychlejší kód
Oblast $A$6:$K$43 jsem si dal do názvu Data
Sub subReplaceData()
'Data: =List1!$A$6:$K$43

Dim lCalc As Long
lCalc = Application.Calculation
Application.Calculation = xlCalculationManual

With Names("Data").RefersToRange

.Value = .Value 'převede buňky, které se tváří jako prázdné na opravdu prázdné

Dim rData As Range
On Error Resume Next
Set rData = Intersect(.Cells, .SpecialCells(xlCellTypeConstants).EntireRow)
On Error GoTo 0

If Not rData Is Nothing Then
Dim vValues() As Variant
ReDim vValues(0)
Dim rArea As Range
For Each rArea In rData.Areas
If IsEmpty(vValues(0)) Then
vValues(0) = rArea.Value
Else
ReDim Preserve vValues(UBound(vValues) + 1)
vValues(UBound(vValues)) = rArea.Value
End If
Next rArea
Set rArea = Nothing

.ClearContents

Dim iRow As Long
iRow = 1
Dim v As Variant
For Each v In vValues
.Cells(iRow, 1).Resize(UBound(v, 1), UBound(v, 2)).Value = v
iRow = iRow + UBound(v, 1)
Next v

End If

End With 'Names("Data").RefersToRange

Application.Calculation = lCalc

Set rData = Nothing
End Sub

Edit:
Vypnutí kalkulacícitovat

Martin12345678(29.1.2014 22:25)#017602

Děkuji vyzkouším:-)citovat

Martin12345678(30.1.2014 4:25)#017608

To eLCHa: Díky, funguje rychleji, což se mě hodí. Jen ignoruje 4 prázdné řádky za sebou. Šlo by to nějak univerzálně ošetřit? Jinak perfekt...citovat

eLCHa(30.1.2014 7:25)#017612

Jen ignoruje 4 prázdné řádky za sebou

Na kód od cmucha jste reagoval stejně. Pomohla ta jeho úprava?

Mně to nedělá. Testováno na vašem vzorku v E2003 a E2007, data jsem si dal až na poslední řádek a posunulo jak mělo. Jinak bych sem nedával.

Mimochodem - do kódu jsem přidal vypnutí přepočtu listu - spustil jsem s jiným souborem a projevilo se tocitovat

marjankaj(30.1.2014 9:31)#017614

Prečo to nejde riešiť odstránením riadkov?

Toto by nestačilo?

Sub Makro1()
For i = Cells(Rows.Count, "B").End(xlUp).Row To 7 Step -1
If Cells(i, 2) = "" Then Range(Cells(i, "B"), Cells(i, "K")).Delete Shift:=xlUp
Next i
End Subcitovat

eLCHa(30.1.2014 14:25)#017616

@marjankaj
kdyby to šlo jen odstranit, nepotřebujete cyklus. Stačí 2 řádky kódu.
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
netestováno, ale věřím, že by fungovalocitovat

Strana: 1 2 další »

Téma: Posun řádků

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje