|
Hallo Zusammen
Ich hab ein makro gebaut die meine gescrappten dateien richtig Formatiert leider bekommen ich ein "laufzeitfehler 1004 anwendungs oder objektdefinierter fehler".
Bei einem Kollgen funktioniert der code einbanfrei, leider nicht auf meinem pc !
hab den debugg fett makiert !
Ich bitte um hilfe da ich kurz vorm verzweifel bin ;).
'1. Select the .CSV file with the data
'2. Get Data from selected file into the "BD" sheet
'3. Split the data in columns (COL 1 to COL9)
'4. Check which columns can be used from the splited columns
'5. To reduce time of processing, copy the formulas until the last row
'6. For the Title, Amount and Weight we need to do many loop backs until we get the data, for each row
'7. Copy and paste it as values to delete all formulas
'8. Sort and format the data
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
'Get the CSV file from worksheet "PRINCIPAL"
csvFile = Sheets("PRINCIPAL").Range("C3").Value
'Delete all worksheets except "PRINCIPAL"
'*You can change it just to find if "BD" exits and then delete it (if you will have more worksheets on this file)
For Each Sheet In wb1.Sheets
sn = UCase(Sheet.Name)
If (sn <> "PRINCIPAL") Then
Sheets(sn).Select
ActiveWindow.SelectedSheets.Delete
End If
Next Sheet
'Create the worksheet "BD"
Set ws = ThisWorkbook.Sheets.Add
ws.Name = "BD"
'Create the connection "result_query" to get the data from the cvsFILE (just 1 column, no transformation)
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
'Delete aditional columns created after importing data
Columns("B:B").Delete Shift:=xlToLeft
'Delete the created connection after getting the data
ActiveSheet.ListObjects("result_query").Unlink
ActiveWorkbook.Queries("result_query").Delete
'Copy as values to delete range
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
'FreezePanes at first row
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
'Get the last Row
lRow = Cells(Rows.Count, 1).End(xlUp).Row
' After importing the data we check that inside the Title column we find characters like , ' "
' Example: 303,'Langnese Mini-Honig-Spezialitäten 3x 33,3 g','`33,3','3,23 €/100 g','3,23 €',N/A,https://www.edeka24.de/Lebensmittel/Fruehstueck/Honig/Langnese-Mini-Honig-Spezialitaeten-3x-33-3-g.html,https:www.edeka24.de/out/pictures/generated/product/1/480_480_90/4023300936806langnese3ermini-spezialitten.jpg,
' So we replace *,'* for *,¿*, because if just replace the ' for ¿, we can separate in more columns that contains ' inside them
' So do the same replace for *',* for *¿,*, to change the end of the column too
c = 1
ini = 1
fin = lRow + 500
Do
*Dort bekomme ich ein Fehler Angezeigt beim debuggen ------> 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
' Columns("A:A").Replace What:=",""", Replacement:=",¿", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
' Columns("A:A").Replace What:=""",", Replacement:="¿,", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Range("A1").Value = "Large String"
Range("B1").Value = "COL 1" ' Article Number : 1
Range("C1").Value = "COL 2" ' Title: Bio EDEKA Brotkorb 5 Sorten Brot in Portionen 500g
Range("D1").Value = "COL 3" ' Weight : `500g
Range("E1").Value = "COL 4" ' Price : 4.30 €/1 kg
Range("F1").Value = "COL 5" ' PaidPrice: 2.15 €
Range("G1").Value = "COL 6" ' Article Number: N/A
Range("H1").Value = "COL 7" ' Link : https://www.edeka24.de/Lebensmittel/Fruehstueck/Brot-Broetchen/Bio-EDEKA-Brotkorb-5-Sorten-Brot-in-Portionen-500g.html
Range("I1").Value = "COL 8" ' ImageURL : https:www.edeka24.de/out/pictures/generated/product/1/480_480_90/bio_edeka_brotkorb_5_sorten_brot_in_portionen_500g.jpg
Range("J1").Value = "COL 9" ' Auxiliar column in case there are more divisions
Range("K1").Value = "Article Number" ' = COL 1
Range("L1").Value = "Title" ' Get data from COL 2
Range("M1").Value = "Amount" ' Get data from COL 2
Range("N1").Value = "Weight" ' Get data from COL 2
Range("O1").Value = "Price" ' = 5
Range("P1").Value = "Category" ' Get data from COL 7
Range("Q1").Value = "Link" ' = COL 7
Range("R1").Value = "Image Url" ' = COL 8
Range("S1").Value = "Article Number" ' = COL 9
Range("T1").Value = "AUX" ' Auxiliar column, if I got data from COL 1 to COL 8
c = 2 ' counter number of rows
'Split LargeString in columns
Do
c_aux = 1
c_col = 2
flag = -1 ' flag = -1 /column start ; flag = 1 / column end
aux = ""
ini = 1
sTexto = Sheets("BD").Range("A" & c).Value
lTexto = Len(sTexto)
Do
If (c_col = 2) Then ' For 1st column: loop until find the first ,
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 ' For other columns
If (Mid(sTexto, c_aux, 1) = "¿" And flag = -1) Then ' If a column start after , with ¿
aux = "¿"
c_aux = c_aux + 1
flag = 1
ElseIf (Mid(sTexto, c_aux, 1) = "," And flag = -1) Then ' If a column start after ,
aux = ","
flag = 1
End If
If (Mid(sTexto, c_aux, 1) = aux And flag = 1) Then ' Loop until find the same aux ( , or ¿) from the begining
Cells(c, c_col).Value = Mid(sTexto, ini + 1, c_aux - ini - 1)
c_col = c_col + 1
If (aux = "¿") Then ' if the column start / finish with ¿ we need to add 1 because in next loop will assume the , as the finish too
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
' Check if we can use the data for the final columns from the split columns
Range("K2").Value = "=IF(RC[9]=8,IFERROR(RC[-9],""""),"""")" ' Article Number
Range("O2").Value = "=IF(RC[5]=8,SUBSTITUTE(RC[-9],""¿"",""""),"""")" ' Price
Range("P2").Value = "=IF(RC[4]=8,IFERROR(MID(RC[1],24,FIND(""/"",RC[1],25)-24),""""),"""")" ' Category from Link Column (Column Q)
Range("Q2").Value = "=IF(RC[3]=8,IFERROR(RC[-9],""""),"""")" ' Link
Range("R2").Value = "=IF(RC[2]=8,IFERROR(RC[-9],""""),"""")" ' Image Url
Range("S2").Value = "=IF(RC[1]=8,IFERROR(RC[-12],""""),"""")" ' Article Number
Range("T2").Value = "=COUNTA(RC[-18]:RC[-10])" ' Counter if we got at least 8 columns with data
' Copy formula from row 2 to the last row
Range("K2:T2").Copy Range("K2:T" & lRow)
' Create an array with all numbers and possibilities (0123456789, .)
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) = "," ' The comma is saved as empty on the array, so we add a valitation on the IsInArray function
aNumber(11) = " "
c = 2
' Loop for each character of COL 2 to separate Title, Amount and Weight
Do
If (Range("T" & c).Value = 8) Then ' if the row has at least 8 columns
aux = 1
sTexto = Sheets("BD").Range("C" & c).Value
lTexto = Len(sTexto)
c_aux = lTexto
If (IsNumeric(Right(sTexto, 1)) = True) Then ' if the last character is a number
Do
If (IsInArray(Mid(sTexto, c_aux, 1), aNumber) = False) Then ' loop back until we found a character which doesnt exits on aNumber array
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 ' If the last character is a letter (for G, KG, ML, etc)
Do
If (IsInArray(Mid(sTexto, c_aux, 1), aNumber) = True) Then ' loop back until we found the first number, just to get the position of this character
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 ' loop back until we found a character which doesnt exits on aNumber array
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 ' we delimited just 5 characters after the end to find the x (because some articles has x inside their names)
' After we got the weight, we need to find the X if the Amount is more then 1
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 ' loop back until we found a X or an space
Exit Do
End If
c_aux = c_aux - 1
Loop While Not c_aux < aux
If (c_aux < aux) Then ' if in 5 characters after the first character of the weight doesnt find the X, the amount is 1
Range("M" & c).Value = 1
Range("L" & c).Value = WorksheetFunction.Trim(Mid(Sheets("BD").Range("C" & c).Value, 1, c_aux + 5))
Else ' we found X
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 ' loop back until we found a character which doesnt exits on aNumber array (so we get the full amount)
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
' Revert the conversion made at the beginning
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("A:A").Replace What:=",¿", Replacement:=",""", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
' Columns("A:A").Replace What:="¿,", Replacement:=""",", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'
' Columns("L:L").Replace What:="¿", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
' Copy as values all the final columns
Columns("K:T").Copy
Columns("K:T").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
' Delete COL 1 to COL 9 columns
Columns("B:J").Delete Shift:=xlToLeft
' Sort the data with the column AUX, to get at the bottom the rows with errors
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
' Delete column AUX
Columns("K:K").Delete Shift:=xlToLeft
' Resize column A
Columns("A:A").ColumnWidth = 80
Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub GetFile()
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 Sub
Private Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
Dim element As Variant
On Error GoTo IsInArrayError: 'array is empty
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
|