AW: CSV-Export mehrer Tabellenblätter mit Userform
09.11.2006 16:06:40
Rudi
Hallo,
eine Userform mit 2 Buttons (cmdOK und cmdCancel) anlegen.
in den Code der UF:
Option Explicit
Private Sub cmdCancel_Click()
Me.Hide
Unload Me
End Sub
Private Sub cmdOK_Click()
Dim iCounter As Integer
Dim strWKS As String
Dim objChkBox As Control, objTxtBox As Control
Application.ScreenUpdating = False
For Each objChkBox In Me.Controls
If TypeOf objChkBox Is MSForms.CheckBox And objChkBox = True Then
Call prcCSV(objChkBox.Caption)
End If
Next
Me.Hide
Unload Me
Set objChkBox = Nothing
Set objTxtBox = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_Initialize()
Dim Wks As Worksheet
Dim objChkBox As Control, objTxtBox As Control
Dim iCounter As Integer
Const iBoxWidth As Integer = 200
For Each Wks In Worksheets
If Wks.Visible Then
iCounter = iCounter + 1
Set objChkBox = Me.Controls.Add("forms.checkbox.1")
With objChkBox
.Left = 15
.Top = iCounter * 15
.Width = iBoxWidth
.Caption = Wks.Name
End With
End If
Next
With Me
With .cmdOK
.Top = objChkBox.Top + objChkBox.Height + 20
.Left = 15
End With
With .cmdCancel
.Top = objChkBox.Top + objChkBox.Height + 20
.Left = cmdOK.Left + cmdOK.Width + 15
End With
.Width = (iBoxWidth * 2 + 40) + (objTxtBox Is Nothing) * (iBoxWidth + 25)
.Height = .cmdOK.Top + .cmdOK.Height + 50
End With
Set Wks = Nothing
Set objChkBox = Nothing
Set objTxtBox = Nothing
End Sub
'in ein Modul:
Sub prcCSV(strDateiName As String)
Dim iCol As Byte, iRow As Integer, _
iR As Integer, iC As Byte, strTxt As String, _
strMldg As String, strTmp As String
Const strSep As String = ";"
Reset
With Sheets(strDateiName).UsedRange
iRow = .Rows.Count
iCol = .Columns.Count
End With
Open ThisWorkbook.Path & "\" & strDateiName & ".csv" For Output As #1
With Sheets(strDateiName).UsedRange
For iR = 1 To iRow
strTxt = ""
For iC = 1 To iCol
strTmp = .Cells(iR, iC)
strTxt = strTxt & strTmp & strSep
Next iC
strTxt = Left(strTxt, Len(strTxt) - 1)
Print #1, strTxt
Next iR
End With
Close #1
End Sub
Gruß
Rudi