VBA Export in mehrere Dateien

Sub exportieren() Dim varSpalten Dim intSpalte As Integer, lngZeile As Long Dim objQuellblatt As Worksheet Dim objZielblatt As Worksheet Dim strPfad As String Dim varTmp, strOut As String Open "\\Server\Daten\00 dateiname.txt" For Output As #1 'anpassen 'Datenquelle festlegen Set objQuellblatt = ThisWorkbook.Sheets("Gesamt") varSpalten = Array(1, 8, 2, 3, 10, 12, 14, 15, 16, 17, 18, 19, 20, 24, 25, 23) varTmp = objQuellblatt.UsedRange For lngZeile = 3 To UBound(varTmp) strOut = "" If Len(varTmp(lngZeile, varSpalten(0))) > 0 Then For intSpalte = 0 To UBound(varSpalten) strOut = strOut & vbTab & varTmp(lngZeile, varSpalten(intSpalte)) Next intSpalte strOut = Mid(strOut, 2) Print #1, strOut End If Next lngZeile Close #1 End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub exportieren() Dim lngZeile&, i& Dim varTmp, strOut As String Dim dic As Object Set dic = CreateObject("Scripting.dictionary") 'Datenquelle festlegen varTmp = ThisWorkbook.Sheets("Gesamt").UsedRange For i = LBound(varTmp) To UBound(varTmp) If Not dic.exists(varTmp(i, 1)) Then dic.Add varTmp(i, 1), 1 Open "\\Server\Daten\" & varTmp(i, 1) & ".txt" For Output As #1 'anpassen For lngZeile = LBound(varTmp) To UBound(varTmp) If varTmp(i, 1) = varTmp(lngZeile, 1) Then strOut = varTmp(i, 1) & vbTab & varTmp(i, 2) Print #1, strOut End If Next lngZeile Close #1 End If Next End Sub

Hallo Alexander,
klarer Fall: diese Zeilen


              strOut = varTmp(i, 1) & vbTab & varTmp(i, 2)
Print #1, strOut

müssen so angepasst werden:


              strOut = varTmp(lngZeile, 1) & vbTab & varTmp(lngZeile, 2)
Print #1, strOut

Andere Möglichkeit, inspiriert von dem Code von Ralf, wollte ich eine Dictionary of Dicitonary probieren:


Sub exportieren()
Dim i, j
Dim arrQuelle
Dim arrTmp
Dim dic As Object
Dim subDic As Object
Set dic = CreateObject("Scripting.dictionary")
'Datenquelle festlegen
arrQuelle = ThisWorkbook.Sheets("Gesamt").UsedRange
'Datenquelle durchgehen und in passende Haupt-Dic zuordnen
For i = LBound(arrQuelle) To UBound(arrQuelle)
If Not dic.exists(arrQuelle(i, 1)) Then
Set subDic = CreateObject("Scripting.dictionary")
subDic.Add "z" & i, Joiner(arrQuelle, i)
dic.Add arrQuelle(i, 1), subDic
Else
dic(arrQuelle(i, 1)).Add "z" & i, Joiner(arrQuelle, i)
End If
Next i
'Jede "Haupt"-Dic Eintrag in einer Datei, wo der Inhalt der SubDic abgelegt wird.
For Each i In dic.keys
Open "\\Server\Daten\" & i & ".txt" For Output As #1 'anpassen
For Each j In dic(i).keys
Print #1, dic(i)(j)
Next j
Close #1
Next i
Set dic = Nothing
End Sub
Private Function Joiner(Arr, Zeile, Optional Trenner = ";")
Dim i
Dim erg
For i = LBound(Arr, 2) To UBound(Arr, 2)
erg = erg & Trenner & Arr(Zeile, i)
Next
Joiner = Mid(erg, Len(Trenner) + 1)
End Function

Da "Joiner" an zwei Stellen geraucht wird, habe ich es ausgelagert.
VG
Yal

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

222 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Export in mehrere Dateien

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

222 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread