Excel - makro pro export listů do nových souborů Vyřešeno

[claxon]

Zdravím,
mám sešit, kde je několik listů - počet není předem určen. Potřeboval bych makro, které mi exportuje každý list zvlášť do nového souboru *.dbf se jménem toho listu do složky ve keré se nachází ten otevřený sešit. Problém je ten, že v druhém listu jsou vzorce, které se odkazujou na první list.
Předem moc díky za pomoc.

[Reklama]

[navstevnik]

podle http://excelplus.net/news.php?readmore=8, http://support.microsoft.com/kb/790163/cs neni export z Excelu do formatu dbf jednoduchou zalezitosti, navic v Ex 2007 neni podporovan.
Nutnost upravy excelovskeho listu pred exportem bude vyzadovat rucni praci, v prvnim odkazu je odkaz na doplnek (http://www.asap-utilities.com), umoznujici export do dbf.
Preji uspech.

[claxon]

Ruční práci mám vyřešenou pomocí jiného makra. Vím, že nelze export z 2007, ale to nevadí, protože cílová skupina jsou uživatelé 2003.
I tak prozatím díky za radu.

[claxon]

Sub SpecialniExport()
Dim Sesit As Workbook
Set Sesit = ActiveWorkbook
' Naetení aktuálního sešitu
Sesit.SaveAs (ActiveWorkbook.Path & "\temp")
' Uložení aktuálního sešitu jako nový soubor s názvem "temp.xls"

Dim i As Long
Dim List As Worksheet
For Each List In Sesit.Worksheets
' Vybrání všech listu v sešitu
Select Case List.Name
' Vybrání listu podle zadaného názvu
Case "Hranice toíd", "Popis", "Úprava"
' Vybrání listu s názvem "Hranice toíd", "Popis", "Úprava"
Application.DisplayAlerts = False
' Deaktivace chybových hlášení
List.Delete
' Vymazání vybraných listu
Application.DisplayAlerts = True
' Aktivace chybových hlášení
Case Else
Dim Bunka As Range
Set Bunka = List.Range("A1")
' Nastavení pole o souoadnicích "A1" jako poeátek tabulky s parametrem "Bunka"
Dim BunkaX As Range
Set BunkaX = List.Range("A2")
' Nastavení pole o souoadnicích "A2" jako poeátek tabulky s parametrem "BunkaX"
Bunka.End(xlDown).EntireRow.Delete
Bunka.End(xlDown).EntireRow.Delete
' Vymazání posledních dvou oádku

Do While BunkaX.Formula <> ""
Select Case UCase(Left(Trim(BunkaX.Value), 3))
Case "KOD"
' Vybrání sloupcu, které mají v záhlaví text obsahující "KOD"
Range(BunkaX, Bunka.End(xlDown)).NumberFormat = "@"
' Zmina formátu vybraných sloupcu na formát "text"
End Select
Set BunkaX = BunkaX.Offset(0, 1)
Loop

Bunka.EntireRow.Delete
' Vymazání prvního oádku
End Select
Next

On Error GoTo Heaven

Dim Sheet As Worksheet
Dim OutputPath As String
Dim OutputFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Dim FileNumber As Byte

For Each Sheet In Sheets
Dim SheetName As String
If Len(Sheet.Name) > 8 Then
FileNumber = FileNumber + 1
SheetName = LCase(Left(Sheet.Name, 6))
SheetName = SheetName & Format("00", FileNumber)
Else
SheetName = LCase(Sheet.Name)
End If
SheetName = Replace(SheetName, "e", "c")


OutputFile = ActiveWorkbook.Path & "\" & SheetName & ".dbf"
' Uloží každý list zvláš? se jménem listu a poíponou .dbf
Sheet.Copy
' Zkopíruje a vytvooí nový sešit s jedním listem, tato kopie sešitu se stane aktivní
ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlDBF4, CreateBackup:=False
ActiveWorkbook.Close
Next

Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub

Heaven:
MsgBox "Nelze uložit ve formátu DBF." & vbCrLf & _
"Zdroj: " & Err.Source & " " & vbCrLf & _
"Eíslo chyby: " & Err.Number & " " & vbCrLf & _
"Popis: " & Err.Description & " " & vbCrLf
GoTo Finally


MsgBox "Úprava sešitu byla úspišni provedena.", vbOKOnly, "Oznámení"
' V poípadi, že úprava probihne v pooádku, oznámí uživateli

End Sub

[claxon]

Tak jsem to nakonec vyřešil sám. Díky. Kdyby měl někdo podobný problém, na dotazy odpovím. Pište na mail.