der Debugger zeigt mit den fehler im gekennzeichneten feld (----->) unten an ????
Sub SplitCSV()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb1 As Workbook
Dim csvFile As String
Set wb1 = ActiveWorkbook
Dim lTexto, c, c_aux, c_col, flag, ini As Long
csvFile = Sheets("PRINCIPAL").Range("C3").Value
For Each Sheet In wb1.Sheets
sn = UCase(Sheet.Name)
If (sn <> "PRINCIPAL") Then
Sheets(sn).Select
ActiveWindow.SelectedSheets.Delete
End If
Next Sheet
Set ws = ThisWorkbook.Sheets.Add
ws.Name = "BD"
ActiveWorkbook.Queries.Add Name:="result_query", Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Origen = Csv.Document(File.Contents(""" & csvFile & """),[Delimiter="";"", Columns=2, Encoding=65001, QuoteStyle=QuoteStyle.None])," & Chr(13) & "" & Chr(10) & " #""Tipo cambiado"" = Table.TransformColumnTypes(Origen,{{""Column1"", type text}, {""Column2"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Tipo cambiado"""
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=result_query;Extended Properties=""""", Destination:=Range("$A$1")).QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [result_query]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "result_query"
.Refresh BackgroundQuery:=False
End With
Columns("B:B").Delete Shift:=xlToLeft
ActiveSheet.ListObjects("result_query").Unlink
ActiveWorkbook.Queries("result_query").Delete
Columns("A:A").Copy
Columns("B:B").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("A:A").Delete Shift:=xlToLeft
Rows("1:1").Delete Shift:=xlUp
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
lRow = Cells(Rows.Count, 1).End(xlUp).Row
c = 1
ini = 1
fin = lRow + 500
Do
->>>>> Range("A" & ini & ":A" & (ini + 500)).Replace What:=",""", Replacement:=",¿", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Range("A" & ini & ":A" & (ini + 500)).Replace What:=""",", Replacement:="¿,", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
ini = c * 500
c = c + 1
Loop While Not ini > fin
Range("A1").Value = "Large String"
Range("B1").Value = "COL 1"
Range("C1").Value = "COL 2"
Range("D1").Value = "COL 3"
Range("E1").Value = "COL 4"
Range("F1").Value = "COL 5"
Range("G1").Value = "COL 6"
Range("H1").Value = "COL 7"
Range("I1").Value = "COL 8"
Range("J1").Value = "COL 9"
Range("K1").Value = "Article Number"
Range("L1").Value = "Title"
Range("M1").Value = "Amount"
Range("N1").Value = "Weight"
Range("O1").Value = "Price"
Range("P1").Value = "Category"
Range("Q1").Value = "Link"
Range("R1").Value = "Image Url"
Range("S1").Value = "Article Number"
Range("T1").Value = "AUX"
c = 2
Do
c_aux = 1
c_col = 2
flag = -1
aux = ""
ini = 1
sTexto = Sheets("BD").Range("A" & c).Value
lTexto = Len(sTexto)
Do
If (c_col = 2) Then
If (Mid(sTexto, c_aux, 1) = ",") Then
Cells(c, c_col).Value = Mid(sTexto, 1, c_aux - 1)
c_col = c_col + 1
ini = c_aux
aux = ","
End If
Else
If (Mid(sTexto, c_aux, 1) = "¿" And flag = -1) Then
aux = "¿"
c_aux = c_aux + 1
flag = 1
ElseIf (Mid(sTexto, c_aux, 1) = "," And flag = -1) Then
aux = ","
flag = 1
End If
If (Mid(sTexto, c_aux, 1) = aux And flag = 1) Then
Cells(c, c_col).Value = Mid(sTexto, ini + 1, c_aux - ini - 1)
c_col = c_col + 1
If (aux = "¿") Then
c_aux = c_aux + 1
End If
ini = c_aux
flag = -1
aux = ","
End If
End If
c_aux = c_aux + 1
Loop While Not c_aux > lTexto
c = c + 1
Loop While Not c > lRow
Range("K2").Value = "=IF(RC[9]=8,IFERROR(RC[-9],""""),"""")"
Range("O2").Value = "=IF(RC[5]=8,SUBSTITUTE(RC[-9],""¿"",""""),"""")"
Range("P2").Value = "=IF(RC[4]=8,IFERROR(MID(RC[1],24,FIND(""/"",RC[1],25)-24),""""),"""")"
Range("Q2").Value = "=IF(RC[3]=8,IFERROR(RC[-9],""""),"""")"
Range("R2").Value = "=IF(RC[2]=8,IFERROR(RC[-9],""""),"""")"
Range("S2").Value = "=IF(RC[1]=8,IFERROR(RC[-12],""""),"""")"
Range("T2").Value = "=COUNTA(RC[-18]:RC[-10])"
Range("K2:T2").Copy Range("K2:T" & lRow)
Dim aNumber(12) As String
aNumber(0) = "0"
aNumber(1) = "1"
aNumber(2) = "2"
aNumber(3) = "3"
aNumber(4) = "4"
aNumber(5) = "5"
aNumber(6) = "6"
aNumber(7) = "7"
aNumber(8) = "8"
aNumber(9) = "9"
aNumber(10) = "."
aNumber(11) = ","
aNumber(11) = " "
c = 2
Do
If (Range("T" & c).Value = 8) Then
aux = 1
sTexto = Sheets("BD").Range("C" & c).Value
lTexto = Len(sTexto)
c_aux = lTexto
If (IsNumeric(Right(sTexto, 1)) = True) Then
Do
If (IsInArray(Mid(sTexto, c_aux, 1), aNumber) = False) Then
Range("N" & c).Value = WorksheetFunction.Trim(Mid(sTexto, c_aux + 1, 100))
Exit Do
End If
aux = aux + 1
c_aux = c_aux - 1
Loop While Not c_aux < 0
Else
Do
If (IsInArray(Mid(sTexto, c_aux, 1), aNumber) = True) Then
Exit Do
End If
aux = aux + 1
c_aux = c_aux - 1
Loop While Not c_aux < 0
aux = 1
sTexto = Left(sTexto, c_aux)
lTexto = Len(sTexto)
c_aux = lTexto
Do
If (IsInArray(Mid(sTexto, c_aux, 1), aNumber) = False) Then
Range("N" & c).Value = WorksheetFunction.Trim(Mid(Sheets("BD").Range("C" & c).Value, c_aux + 1, 100))
Exit Do
End If
aux = aux + 1
c_aux = c_aux - 1
Loop While Not c_aux < 0
End If
sTexto = Left(sTexto, c_aux + 1)
lTexto = Len(sTexto)
c_aux = lTexto
aux = c_aux - 5
Do
If (Mid(sTexto, c_aux, 1) = "x" And (Mid(sTexto, c_aux - 1, 1) = " " Or IsInArray(Mid(sTexto, c_aux - 1, 1), aNumber))) Then
Exit Do
End If
c_aux = c_aux - 1
Loop While Not c_aux < aux
If (c_aux < aux) Then
Range("M" & c).Value = 1
Range("L" & c).Value = WorksheetFunction.Trim(Mid(Sheets("BD").Range("C" & c).Value, 1, c_aux + 5))
Else
aux = c_aux - 1
sTexto = Left(sTexto, c_aux - 1)
lTexto = Len(sTexto)
c_aux = lTexto
Do
If (IsInArray(Mid(sTexto, c_aux, 1), aNumber) = False) Then
Range("M" & c).Value = WorksheetFunction.Trim(Mid(Sheets("BD").Range("C" & c).Value, c_aux + 2, aux - (c_aux + 2 + 1)))
Range("L" & c).Value = WorksheetFunction.Trim(Mid(Sheets("BD").Range("C" & c).Value, 1, c_aux))
Exit Do
End If
aux = aux + 1
c_aux = c_aux - 1
Loop While Not c_aux < 0
End If
End If
c = c + 1
Loop While Not c > lRow
c = 1
ini = 1
fin = lRow + 500
Do
Range("A" & ini & ":A" & (ini + 500)).Replace What:=",¿", Replacement:=",""", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Range("A" & ini & ":A" & (ini + 500)).Replace What:="¿,", Replacement:=""",", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Range("L" & ini & ":L" & (ini + 500)).Replace What:="¿", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
ini = c * 500
c = c + 1
Loop While Not ini > fin
Columns("K:T").Copy
Columns("K:T").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("B:J").Delete Shift:=xlToLeft
ActiveWorkbook.Worksheets("BD").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("BD").Sort.SortFields.Add2 Key:=Range("K2:K" & lRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("BD").Sort
.SetRange Range("A1:K" & lRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("K:K").Delete Shift:=xlToLeft
Columns("A:A").ColumnWidth = 80
Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub GetFile()
If (IsMac) Then
Dim MyPath As String
Dim MyScript As String
Dim MyFiles As String
Dim MySplit As Variant
Dim N As Long
Dim Fname As String
Dim mybook As Workbook
Dim OneFile As Boolean
Dim FileFormat As String
FileFormat = "{""public.comma-separated-values-text""}"
OneFile = True
On Error Resume Next
MyPath = MacScript("return (path to desktop folder) as String")
If Val(Application.Version) < 15 Then
If OneFile = True Then
MyScript = _
"set theFile to (choose file of type" & _
" " & FileFormat & " " & _
"with prompt ""Please select a file"" default location alias """ & _
MyPath & """ without multiple selections allowed) as string" & vbNewLine & _
"return theFile"
Else
MyScript = _
"set applescript's text item delimiters to {ASCII character 10} " & vbNewLine & _
"set theFiles to (choose file of type" & _
" " & FileFormat & " " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ with multiple selections allowed) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"
End If
Else
If OneFile = True Then
MyScript = _
"set theFile to (choose file of type" & _
" " & FileFormat & " " & _
"with prompt ""Please select a file"" default location alias """ & _
MyPath & """ without multiple selections allowed) as string" & vbNewLine & _
"return posix path of theFile"
Else
MyScript = _
"set theFiles to (choose file of type" & _
" " & FileFormat & " " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ with multiple selections allowed)" & vbNewLine & _
"set thePOSIXFiles to {}" & vbNewLine & _
"repeat with aFile in theFiles" & vbNewLine & _
"set end of thePOSIXFiles to POSIX path of aFile" & vbNewLine & _
"end repeat" & vbNewLine & _
"set {TID, text item delimiters} to {text item delimiters, ASCII character 10}" & vbNewLine & _
"set thePOSIXFiles to thePOSIXFiles as text" & vbNewLine & _
"set text item delimiters to TID" & vbNewLine & _
"return thePOSIXFiles"
End If
End If
MyFiles = MacScript(MyScript)
On Error GoTo 0
If MyFiles <> "" Then
Range("C3").Value = MyFiles
End If
Else
On Error Resume Next
fldr = Application.GetOpenFilename(Title:="Select a file", FileFilter:="Report Files *.csv* (*.csv*),")
On Error GoTo 0
If (fldr <> False) Then
Range("C3").Value = fldr
Else
Range("C3").Value = ""
End If
Set fldr = Nothing
End If
End Sub
Private Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
Dim element As Variant
On Error GoTo IsInArrayError:
For Each element In arr
If (element = valToBeFound Or valToBeFound = ",") Then
IsInArray = True
Exit Function
End If
Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function
Function IsMac() As Boolean
#If Mac Then
IsMac = True
#End If
End Function
Function Is64BitOffice() As Boolean
#If Win64 Then
Is64BitOffice = True
#End If
End Function
Function Excelversion() As Double
Excelversion = Val(Application.Version)
End Function
Function FileExists(FullFileName As String) As Boolean
FileExists = Len(Dir(FullFileName)) > 0
End Function
Function FileOrFolderExistsOnMac(FileOrFolderstr As String) As Boolean
Dim ScriptToCheckFileFolder As String
Dim TestStr As String
If Val(Application.Version) < 15 Then
ScriptToCheckFileFolder = "tell application " & Chr(34) & "System Events" & Chr(34) & _
"to return exists disk item (" & Chr(34) & FileOrFolderstr & Chr(34) & " as string)"
FileOrFolderExistsOnMac = MacScript(ScriptToCheckFileFolder)
Else
On Error Resume Next
TestStr = Dir(FileOrFolderstr & "*", vbDirectory)
On Error GoTo 0
If Not TestStr = vbNullString Then FileOrFolderExistsOnMac = True
End If
End Function