< návrat zpět

MS Excel

Téma: makro datum na text v tvare (d.mesiac.rok) rss

Zaslal/a frantilopa 2.5.2021 16:00

frantilopaDobry den, prosim o pomoc.
Vytvoril som si makro v module, ktore po spusteni vytvori novy excelovsky zosit a skopiruje do neho povodny harok (aktivny harok), ale iba vo formate textu (takto to potrebujem!).
Problem mam s telefonnymi cislami a datumami, ktore chcem aby taktiez boli ako text v tvare zrozumitelnom 21. máj 1972 a 0915 123 456.
Mne to prepise datum na cislo a telefon bez nuly.
Viete mi pomoct?
Dakujem.
PS. Pouzivam viacero tabuliek preto kazdy harok je iny nechcem, aby to fixovalo na jeden konkretny stlpec lepsie by bolo ak by makro vyhladalo ktoru bunku ma dat na datum resp. tel. cislo
F. 1

Příloha: rar50575_export-harku.rar (20kB, staženo 17x)
Zaslat odpověď >
Milan-158(3.5.2021 13:33)#050582
avatar
Třeba takhle:
Public Sub EXPORT_Harku_do_textu()

Application.EnableEvents = False
' tento zapis zaisti to, ze bude znemoznene volanie procedur spustenych na zaklade udalosti. Na konci kodu je nutne udalosti znovu 'zapnut'

Dim cesta As String
Dim nove_meno As String
Dim cele_meno As String
Dim zdroj As String

Dim i As Long, iMxRow As Long

iMxRow = Range("E65000").End(xlUp).Row
If iMxRow > 4 Then
For i = 4 To iMxRow
Cells(i, "E") = CStr(Cells(i, "E").Text)
Next i
End If

zdroj = ActiveWorkbook.Name ' nastavenie mena zdroju - meno povodneho zositu
cesta = ActiveWorkbook.Path ' nastavenie cesty pre ulozenie dat - tam kde bol povodny zosit otvoreny
Application.DisplayAlerts = False

ActiveSheet.Copy ' skopiruje cely aktivny harok do noveho zositu
ActiveSheet.Cells.UnMerge ' zrusi zlucenie buniek
Workbooks(zdroj).ActiveSheet.Cells.Copy ' skopiruje povodny harok
ActiveSheet.Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' iba hodnoty skopiruje do noveho harku (aby nekopirovalo pripadne vzorce vsetko potrebujem mat v texte)
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells.NumberFormat = "@" ' nastavi format celeho noveho harku do textu, pretoze cely harok musi byt vo formate textu
ActiveSheet.Columns("H").NumberFormat = "0000 000 000"

nove_meno = "Zosit " ' predpis noveho mena
Dim filename As Variant ' nastavenie cesty pre ulozenie
filename = Application.GetSaveAsFilename(nove_meno, "Excel (*.xlsx),*.*,Excel 98-03 (*.xls),*.*,", 1, "Uložiť ako") ' zobrazi sa okno 'ukladania'
If filename = False Then Exit Sub
cele_meno = filename
ActiveWorkbook.SaveAs (cele_meno) ' ulozenie zositu do standartnej cesty ukladania

ActiveSheet.Cells(1, 1).Select ' odklikni oznacenie celeho harku
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.EnableEvents = True ' volanie procedur spustenych na zaklade udalosti 'zapnut'
End Subcitovat
frantilopa(3.5.2021 14:57)#050587
frantilopa
Dakujem, ale..
.. pisal som, ze nechcem to fixovat na jeden konkretny stlpec, kedze tento kod sa nehodi na iny harok (kde datumy alebo tel. cisla nie su v stlpci E a H, ale su niekde inde a podalsie v stlpci H nie je textovy format, ale vlastny).
Mal som predstavu ci neexistuje kod, ktory:
prepise datumove a ciselne formaty na text univerzalne nie zafixovane na jeden stlpec
alebo
identifikuje (vyhlada) bunky, ktore su vo formate datumu alebo tel. cisla a nasledne tie bunky prepise na text.
Dakujem F.citovat
Jiří497(3.5.2021 20:25)#050590
avatar
Trošku jsem to od @Milan-158 doplnil.
Sloupec vyhledá podle hlavičky. Pozor! Sloupec "Telefónne číslo" mělo vprostřed odřádkování a na konci mezeru. Je potřeba opravit buď hlavičku v tabulce a nebo název v makru. Musí to být stejné, jinak to nenajde.

Public Sub EXPORT_Harku_do_textu()

Application.EnableEvents = False
' tento zapis zaisti to, ze bude znemoznene volanie procedur spustenych na zaklade udalosti. Na konci kodu je nutne udalosti znovu 'zapnut'

Dim cesta As String
Dim nove_meno As String
Dim cele_meno As String
Dim zdroj As String

zdroj = ActiveWorkbook.Name ' nastavenie mena zdroju - meno povodneho zositu
cesta = ActiveWorkbook.Path ' nastavenie cesty pre ulozenie dat - tam kde bol povodny zosit otvoreny
Application.DisplayAlerts = False

ActiveSheet.Copy ' skopiruje cely aktivny harok do noveho zositu
ActiveSheet.Cells.UnMerge ' zrusi zlucenie buniek

'********************************** vložený kód ****************************

Dim i As Long, iMxRow As Long
Dim sloupecDatum As Long, sloupecTelefon As Long
Dim NajdiDatum As Range
Dim NajdiTelefon As Range

'******* najde sloupec s datem
Set NajdiDatum = Range("4:4").Find("Dátum narodenia")
If NajdiDatum Is Nothing Then
MsgBox ("Sloupec s datem nenalezen")
Else
sloupecDatum = NajdiDatum.Column
End If

'******** najde sloupec s telefonem
Set NajdiTelefon = Range("4:4").Find("Telefónne číslo")
If NajdiTelefon Is Nothing Then
MsgBox ("Sloupec s telefon nenalezen")
Else
sloupecTelefon = NajdiTelefon.Column
End If

iMxRow = Range("E65000").End(xlUp).Row
If iMxRow > 4 Then
For i = 5 To iMxRow
Cells(i, sloupecDatum) = Format(Cells(i, sloupecDatum).Text, "'dd.mmm.yyyy'")
Cells(i, sloupecTelefon) = Format(Cells(i, sloupecTelefon).Text, "0000\ 000\ 000")
Next i
End If

'*************************************** End *************************************

'Workbooks(zdroj).ActiveSheet.Cells.Copy ' skopiruje povodny harok
'ActiveSheet.Cells(1, 1).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' iba hodnoty skopiruje do noveho harku (aby nekopirovalo pripadne vzorce vsetko potrebujem mat v texte)
'Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells.NumberFormat = "@" ' nastavi format celeho noveho harku do textu, pretoze cely harok musi byt vo formate textu

nove_meno = "Zosit " ' predpis noveho mena
Dim filename As Variant ' nastavenie cesty pre ulozenie
filename = Application.GetSaveAsFilename(nove_meno, "Excel (*.xlsx),*.*,Excel 98-03 (*.xls),*.*,", 1, "Uložiť ako") ' zobrazi sa okno 'ukladania'
If filename = False Then Exit Sub
cele_meno = filename
ActiveWorkbook.SaveAs (cele_meno) ' ulozenie zositu do standartnej cesty ukladania

ActiveSheet.Cells(1, 1).Select ' odklikni oznacenie celeho harku
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.EnableEvents = True ' volanie procedur spustenych na zaklade udalosti 'zapnut'
End Sub
Příloha: zip50590_export-harku.zip (21kB, staženo 13x)
citovat
Milan-158(4.5.2021 10:24)#050591
avatar
Šlo by to řešit mnoha způsoby. Kdysi jsem potřeboval vytvořit nový sešit z vyfiltrovaných hodnot. Pokud tam filtr není, tak to vytvoří sešit ze všech hodnot. Ve smyčce se tam upravují i šířky sloupců podle originálu. Zkoušel jsem to a funguje to, případně se to dá volně upravit. Zde je kód:
Sub Kopie_listu_filtr()
'z aktivního listu vytvoří nový sešit s pouze přefiltrovanými řádky

Dim jMxCol As Integer
Dim iMxRow As Long, i As Long, iHlp As Long
Dim sgHlp As Single
Dim wbNew As Workbook
Dim ws As Worksheet, wb As Workbook
Dim strFiltAdr As String, strFormat As String
Dim FiltHelp As Boolean
Dim rgAdresa As String

Set wb = ActiveWorkbook
Set ws = ActiveSheet
rgAdresa = ActiveCell.Address

Application.ScreenUpdating = False

'poslední řádek na aktivním listě
'vyzkoušej prvních 10 sloupců
For i = 1 To 10
iHlp = Cells(65000, i).End(xlUp).Row
If iHlp > iMxRow Then iMxRow = iHlp
Next i

'poslední sloupec na aktivním listě
'vyzkoušej prvních 20 řádků
For i = 1 To 20
iHlp = Cells(i, 250).End(xlToLeft).Column
If iHlp > jMxCol Then jMxCol = iHlp
Next i

''pokud není nasazený Filtr, zeptej se jak dál
' If Not w1.FilterMode Then
' If vbNo = MsgBox("Není zadáno žádné filtrování. Budu tedy kopírovat všech " & iMxRow & " řádků " & vbCr & vbCr & _
' "Mám v akci pokračovat?", vbYesNo) Then Exit Sub
' End If

'zjisti rozměry filtru (pro pozdější nasazení stejného filtru do nového souboru)
If ws.AutoFilterMode Then
strFiltAdr = ws.AutoFilter.Range.Address
iHlp = ws.AutoFilter.Range.Columns.Count
FiltHelp = True
End If

'vytvoř nový soubor
Workbooks.Add
Set wbNew = ActiveWorkbook

'kopíruj řádky
wb.Activate
Rows("1:" & iMxRow).Select
Selection.Copy

'vlož kopírované řádky
wbNew.Activate
Selection.PasteSpecial Paste:=xlFormats
' Selection.PasteSpecial Paste:=xlFormulas
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False

'překopíruj šířku sloupců a formát
For i = 1 To jMxCol
wb.Activate
sgHlp = Columns(i).ColumnWidth
' strFormat = Cells(7, i).NumberFormat

wbNew.Activate
Columns(i).ColumnWidth = sgHlp
' If strFormat <> "@" Then Columns(i).NumberFormat = strFormat
Next i


'pokud tam byl filtr, tak nakopíruj i filtr
If FiltHelp Then
Range(strFiltAdr).Select
Selection.AutoFilter
End If

'zkopíruj nastavení lupy
wb.Activate
sgHlp = ActiveWindow.Zoom
wbNew.Activate
ActiveWindow.Zoom = sgHlp

Application.ScreenUpdating = True

Range(rgAdresa).Select

End Subcitovat

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