Excel Makro für csv Export

Question

Hi Leute

Hab hier ein Makro für csv Export aus dem Netz

Sub CSVTab()

Dim Bereich As Object, Zeile As Object, Zelle As Object
Dim strTemp As String
Dim strDateiname As String
Dim strTrennzeichen As String
Dim strMappenpfad As String

strMappenpfad = ActiveWorkbook.FullName
strMappenpfad = Replace(strMappenpfad, ".xls", ".csv")

strDateiname = InputBox("Wie soll die CSV-Datei heißen (c:\test.csv)?", "CSV-Export", strMappenpfad)
If strDateiname = "" Then Exit Sub

strTrennzeichen = InputBox("Welches Trennzeichen soll verwendet werden?", "CSV-Export", ",")

'# GEAENDERT
'# Wenn kein Trennzeichen eingegeben wird (Wichtig: mit "Entf" löschen!), findet TAB (vbTab) Verwendung
If strTrennzeichen = "" Then
strTrennzeichen = vbTab
' Exit Sub ' muss natürlich raus. Er soll ja weitermachen.
End If
'# GEAENDERT

Set Bereich = ActiveSheet.UsedRange

Open strDateiname For Output As #1

For Each Zeile In Bereich.Rows
For Each Zelle In Zeile.Cells
strTemp = strTemp & """" & CStr(Zelle.Text) & """" & strTrennzeichen
Next
If Right(strTemp, 1) = strTrennzeichen Then strTemp = Left(strTemp, Len(strTemp) - 1)
Print #1, strTemp
strTemp = ""
Next

Close #1
Set Bereich = Nothing
MsgBox "Export erfolgreich. Datei wurde exportiert nach" & vbCrLf & strDateiname

End Sub


aber irgendwie funktioniert es nicht wie ich es brauche.
Benötige Csv Export als Tab aber er macht mir stets "" anstatt TAB
zwischen den Zahlen.

Kann mir vielleicht jemand Helfen von den Spezies hier

Answer 1

Hallo M.O

O.K mach ich
und nochmals Vielen Dank für deine Arbeit ist nicht Selbstverständlich

Answer 2

Hallo M.O

O.K mach ich
und nochmals Vielen Dank für deine Arbeit und Zeit ist nicht Selbstverständlich

Answer 3

Danke M.O für deine Arbeit

Answer 4

Hi M.O

Ich muss nocheinma auf den Laufzeitfehler 9 Index außerhalb des gültigen Bereichs zurückkommen.

Ich habe ihn jetzt des öfteren und ich weiss auch warum.

Wenn in der Suchspalte zb
234
118
567
steht und in irgendeiner Spalte die Zahl 234 an letzter Stelle steht kommt diese Meldung.
Entfernt man die Zahl oder ersetzt diese durch eine andere läuft er durch.
Kannst du dirdas vielleicht nochmals anschauen

lg
Leandra

Answer 5

Hallo Leandra,

hatte nicht bedacht, dass die Suchzahlen natürlich auch am Ende einer Spalte stehen können. Falls das der Fall ist, kommt der Fehler, da in dem Array Spalte das nächste Element überprüft werden soll, das es aber nicht gibt.
Hier das korrigierte Makro:

Sub suchen2()

Dim wksBlatt1 As Worksheet
Dim wksBlatt2 As Worksheet
Dim wksBlatt3 As Worksheet
Dim lngLetzte As Long
Dim lngLetzte3 As Long
Dim lngSpalte As Long
Dim lngSpalteL As Long
Dim varSuchen As Variant
Dim varSpalte As Variant
Dim lngZaehler As Long
Dim s As Long
Dim a As Long
Dim e As Long
Dim lngAnfang As Long
Dim lngEnde As Long
Dim lngFarbe As Long
Dim lngZeile As Long
Dim lngEinleseS As Long
Dim lngDurchlauf As Long
Dim lngd As Long

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Arbeitsblätter festlegen
Set wksBlatt1 = ThisWorkbook.Worksheets("Artikelnummern") 'Tabelle, die durchsucht werden soll
Set wksBlatt2 = ThisWorkbook.Worksheets("Suchartikel") 'Tabelle mit den zu suchenden Zahlen
Set wksBlatt3 = ThisWorkbook.Worksheets("Ergebnis") 'Tabelle in die die Suchergebnisse einfügt werden

'Suchzahlen aus Arbeitsblatt Suchartikel in Array einlesen
'dazu die letzte Zeile im Arbeitsblatt in Spalte A ermitteln
With wksBlatt2
lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
'nun ab A1 die Daten in das Sucharray einlesen
varSuchen = .Range(.Cells(1, 1), .Cells(lngLetzte, 1))
End With

'in Zieltabelle für Suchergebnisse ggf. vorhandene Daten löschen
wksBlatt3.Cells.Clear

'Im Suchblatt letzte Spalte ermitteln
lngSpalteL = wksBlatt1.Cells(1, Columns.Count).End(xlToLeft).Column

'Anzahl der Spalten festlegen, die pro Durchlauf eingelesen werden sollen
lngEinleseS = 5

'Anzahl der Durchläufe ermitteln
'Ganzzahl der Durchläufe ermitteln
lngDurchlauf = Int(lngSpalteL / lngEinleseS)
'Prüfen, ob Durchlauf ggf. um 1 erhöht werden muss
If lngSpalteL Mod lngEinleseS > 0 Then lngDurchlauf = lngDurchlauf + 1

'letzte Zeile ermitteln
lngLetzte = wksBlatt1.Cells.SpecialCells(xlCellTypeLastCell).Row

'Schleife, um alle Spalten im Suchblatt zu durchlaufen
For lngd = 0 To lngDurchlauf - 1

With wksBlatt1
'Spalten in Array einlesen
varSpalte = .Range(.Cells(1, 1 + lngd * lngEinleseS), .Cells(lngLetzte, lngEinleseS + lngEinleseS * lngd))
End With

'Vergleich
For lngSpalte = LBound(varSpalte, 2) To UBound(varSpalte, 2)
'Statusmeldung
Application.StatusBar = "Spalte " & lngSpalte + lngd * lngEinleseS & " von " & lngSpalteL & " wird durchsucht "

For a = LBound(varSpalte, 1) To UBound(varSpalte, 1)
'Zaehler auf Null setzen
lngZaehler = 0
For s = LBound(varSuchen, 1) To UBound(varSuchen, 1)
'Prüfen, ob zu vergleichendes Element im Array varSpalte existiert
If a + s - 1 <= UBound(varSpalte, 1) Then
'falls ja, dann vergleichen
If varSpalte(a + s - 1, lngSpalte) = varSuchen(s, 1) Then
lngZaehler = lngZaehler + 1
Else
Exit For
End If
End If
Next s

'Falls Übereinstimmung,
If lngZaehler = UBound(varSuchen, 1) Then

'dann Anfang und Ende des einzufügenden Bereichs festlegen
lngAnfang = a - 2
lngEnde = a + UBound(varSuchen, 1) + 2
'Anfang und Ende prüfen, ob diese im zulässigen Bereich liegen
If lngAnfang < 1 Then lngAnfang = 1
If lngEnde > UBound(varSpalte, 1) Then lngEnde = UBound(varSpalte, 1)
'Zeile für das Einfärben der gefundenen Übereinstimmungen ermitteln
lngFarbe = a - lngAnfang

'letzte Zeile in Einfügespalte = Suchspalte ermitteln
lngLetzte3 = wksBlatt3.Cells(Rows.Count, lngSpalte + lngEinleseS * lngd).End(xlUp).Row + 2
'Einfügezeile ggf. korrigieren
If lngLetzte3 = 3 Then lngLetzte3 = 1
'Inhalte einfügen
With wksBlatt3
'Zähler für Einfügezeile auf Null setzen
lngZeile = 0
For e = lngAnfang To lngEnde
.Cells(lngLetzte3 + lngZeile, lngSpalte + lngEinleseS * lngd) = varSpalte(e, 1)
lngZeile = lngZeile + 1
Next e
End With

'Suchzahlen in gefundener Reihe einfärben
With wksBlatt3
.Range(.Cells(lngLetzte3 + lngFarbe, lngSpalte + lngEinleseS * lngd), .Cells(lngLetzte3 + lngFarbe + UBound(varSuchen, 1) - 1, lngSpalte + lngEinleseS * lngd)).Interior.Color = vbYellow
End With
End If

Next a

Next lngSpalte
Next lngd

'Auf Blatt 3 mit den gefundenen Daten wechseln
With wksBlatt3
.Activate
.Range("A1").Select
End With

Application.StatusBar = False

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 6

Danke jetzt gehts