bestimmte anzahl von zellen kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Lutz!
Kopiere diesn Code in ein allgemeines Modul deiner Datei.
Code anpassen und dann viel Spass!

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Lutz!
Ich hab schon verstanden was du willst!
Das ist ein altbekanntes Problem mit "CSV" export.
Dann müssen wir die CSV halt "zu Fuß" erstellen!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub DatenInNeueMappen()
Dim arr As Variant
Dim n As Integer, lCol As Integer
Dim ws As Worksheet
Dim fRow As Long, lRow As Long
Dim sPath As String, sFile As String, sTemp As String

On Error GoTo ErrorExit

Set ws = ThisWorkbook.Sheets("Tabelle1") '<<<--- Tabelle mit den Daten - Name anpassen

lRow = ws.Range("A65536").End(xlUp).Row
fRow = 1
lCol = 15 '<<<--- Anzahl der Spalten die Exportiert werden sollen - anpassen

sPath = "F:\Temp\" '<<<--- Verzeichnis in dem die einzelnen Mappen _
  gespeichert werden sollen - anpassen!

If Right(sPath, 1) <> "\" Then sPath = sPath & "\"

With Application
  .DisplayAlerts = False
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlCalculationManual
End With

Do

  arr = ws.Range(ws.Cells(fRow, 1), ws.Cells(fRow + 99, lCol))

  sTemp = Join2(arr, ";", True)

  sFile = sPath & fRow & "-" & fRow + 99 & ".csv"

  Close #1

  Open sFile For Output As #1

  Print #1, sTemp;

  Close #1

  fRow = fRow + 100

Loop While fRow < lRow

ErrorExit:
With Application
  .DisplayAlerts = True
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlCalculationAutomatic
End With

End Sub

Function Join2(field As Variant, Optional delimit As String = " ", Optional breakLines As Boolean = False) As String
'zweidimensionales array zu string umwandeln
Dim n As Long, m As Long
Dim temp As String

For n = LBound(field, 1) To UBound(field, 1)
  For m = LBound(field, 2) To UBound(field, 2)

    temp = temp & field(n, m) & delimit

  Next
  If breakLines Then temp = temp & Chr(10)
Next

Join2 = Left(temp, Len(temp) - 1)

End Function

Das sollte jetzt aber klappen!

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

bestimmte anzahl von zellen kopieren

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

bestimmte anzahl von zellen kopieren

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread