MS Excel

Protoze to ma byt dostupne pro vsechny otevrene .csv soubory - vlozte nasledujici tri kody do sesitu Personal.xlsb (office 2007 nebo 2010) a spoustejte kod: Uprava_CSV (dalsi dva kody jsou volane z tlacitek).
- Vyrobce neni ukladan jako vzorec, ale jako text, protoze po ulozeni csv se stejne vsechny vzorce ztrati a zustane jen hodnota.
- klavesovou zkratku pro proceduru Uprava_CSV lze nastavit az u vas v PC

Sub CSV_uprava()
Dim i As Long
Dim Zprava_sesity As String, Vys_sesity
Dim wbSesit As Workbook, Radek As Long

'-------------------------Nastavení sešitu
For i = 1 To Workbooks.Count
If Right(Workbooks(i).Name, 3) = "csv" Then
Zprava_sesity = Zprava_sesity & i & ": " & Workbooks(i).Name & vbNewLine
End If
Next i

Vys_sesity = InputBox("Zapiš číslo CSV souboru, pro který chceš provést změny." & vbNewLine & _
"(pokud soubor není v seznamu, zřejmě není otevřen nebo je otevřen v jiné instanci Excelu)" _
& vbNewLine & "-------------------------------------------------------" & vbNewLine & _
Zprava_sesity, "Vyber CSV soubor...")

If IsNumeric(Vys_sesity) = False Then
MsgBox "Musíte zadat číslo!" & vbNewLine & "Tato procedura bude nyní ukončena...", vbCritical
Exit Sub
End If

If Right(Workbooks(CLng(Vys_sesity)).Name, 3) <> "csv" Then
MsgBox "Toto není platné číslo souboru CSV ze seznamu!" & vbNewLine & "Tato procedura bude nyní ukončena...", vbCritical
Exit Sub
End If

Set wbSesit = Workbooks(CLng(Vys_sesity))
'------------------------------------------------

'-----------------------------------začátek úprav
wbSesit.Activate
Radek = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row

Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("1:1").RowHeight = 45
Range("a1:K1").Interior.Color = vbGreen
Columns("A:K").AutoFilter

Range("A2").Select
ActiveWindow.FreezePanes = True

ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range( _
"D2:D" & Radek), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("A1:K" & Radek)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'tlačítka
ActiveSheet.Buttons.Add(148.5, 4.5, 71.25, 22.5).Select
Selection.OnAction = "PERSONAL.XLSB!Vyrobce1"
Selection.Characters.Text = "Výrobce 1"
With Selection.Characters(Start:=1, Length:=9).Font
.Name = "Calibri"
.FontStyle = "Obyčejné"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With

ActiveSheet.Buttons.Add(230.25, 5.25, 78.75, 22.5).Select
Selection.OnAction = "PERSONAL.XLSB!Vyrobce2"
Selection.Characters.Text = "Výrobce 2"
With Selection.Characters(Start:=1, Length:=9).Font
.Name = "Calibri"
.FontStyle = "Obyčejné"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With

ActiveSheet.Buttons.Add(480.75, 3.75, 46.5, 22.5).Select
Selection.OnAction = "PERSONAL.XLSB!UlozCSV"
Selection.Characters.Text = "ulož CSV"
With Selection.Characters(Start:=1, Length:=8).Font
.Name = "Calibri"
.FontStyle = "Obyčejné"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
Range("a1").Select

End Sub

Sub Vyrobce1()
Dim Sloupec As Long, Vyrobce1 As String
Dim Bunka

Sloupec = 3

If Selection.Columns.Count > 1 Then
MsgBox "Výběr nesmí mít více než 1 sloupec" & vbNewLine & vbNewLine & "...procedura bude ukončena...", vbCritical
Exit Sub
End If

If Selection.Column <> 3 Then
MsgBox "Výběr musí být proveden ve sloupci C (č. 3)" & vbNewLine & vbNewLine & "...procedura bude ukončena...", vbCritical
Exit Sub
End If

For Each Bunka In Selection
Vyrobce1 = Left(Cells(Bunka.Row, 4), InStr(1, Cells(Bunka.Row, 4), " ") - 1)
Bunka.Value = Vyrobce1
Next Bunka

End Sub

Sub Vyrobce2()
Dim Sloupec As Long, Vyrobce2 As String
Dim Bunka

Sloupec = 3

If Selection.Columns.Count > 1 Then
MsgBox "Výběr nesmí mít více než 1 sloupec" & vbNewLine & vbNewLine & "...procedura bude ukončena...", vbCritical
Exit Sub
End If

If Selection.Column <> 3 Then
MsgBox "Výběr musí být proveden ve sloupci C (č. 3)" & vbNewLine & vbNewLine & "...procedura bude ukončena...", vbCritical
Exit Sub
End If

For Each Bunka In Selection
Vyrobce2 = Left(Cells(Bunka.Row, 4), InStr(InStr(1, Cells(Bunka.Row, 4), " ") + 1, Cells(Bunka.Row, 4), " ") - 1)
Bunka.Value = Vyrobce2
Next Bunka

End Sub

Sub UlozCSV()
ActiveWindow.FreezePanes = False
Rows(1).Delete
ActiveWorkbook.SaveAs , FileFormat:=xlCSV
ActiveWorkbook.Close True
End Subcitovat

Moc díky Poki za návod hotový kód.
Práce s personal souborem se mi zdá moc komplikovaná, trochu jsem to poupravil o načítání přímo do aktivního listu a ukládání upravených souborů (nevyráběl jsem, jen upravil a slepil už hotové části), ale bohužel, načítání není zrovna "kalup" :-(
nebylo by možné namísto pracného cucání buněk a následného přejmenování listu rovnou z vybraného csv zkopírovat celý list i s jeho názvem? Myslím, že by to mohlo být podstatně rychlejší... (zdrojový soubor by se nemusel ani otevírat - jestli to lze).
Pro mně je to ale moc "vysoká pilotáž" ...
pokud bys byl ještě ochoten poradit
ještě je tu jedna drobnost se kterou jsem si neporadil - cyklické zapínání/vypínání aut.filtru v každém dalším průchodu načtení - potřebuju ho zapnutý pro úpravy - použil jsem příkaz 2x, ale asi to není ideální řešení...
díky
Bery

Příloha: zip

12652_upravy_data.zip (39kB, staženo 36x)

citovat

Téma: makro pro vložení vzorce do rozsahu buněk

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje