Все нормально, флудите, много интересного может из этого получится.
вот у меня макрос, который подготавливает файл для заливки на сайт обновленного наличие и цены на существующий товар + подготавливает файл заливки нового товара
Sub Импорт()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
CPath = ThisWorkbook.Path
ControlFile = ActiveWorkbook.Name
ImportFile = CPath + "" + "pprice_list.xls"
Workbooks.Open (ImportFile)
ActiveSheet.Copy After:=Workbooks(ControlFile).ActiveSheet
Workbooks("pprice_list.xls").Activate
Workbooks("pprice_list.xls").Close SaveChanges:=False
Call ПреобразоватьЯчейки
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub ПреобразоватьЯчейки()
Rows("1:1").Delete Shift:=xlUp
With ActiveSheet.Range("$D$1:$D$15000")
.Formula = .Value
End With
On Error Resume Next
For Each cell In Selection.Cells.SpecialCells(xlCellTypeConstants, xlNumbers)
Next
Call УдалениеСтрок
End Sub
Sub УдалениеСтрок()
Dim ra As Range, delra As Range
' ищем и удаляем строки, содержащие заданный текст
' (можно указать сколько угодно значений, и использовать подстановочные знаки)
УдалятьСтрокиСТекстом = Array("ИСТОЧНИКИ ПИТАНИЯ *", "МЕДТЕХНИКА", "ПРОЧЕЕ", "ФОТОЛАБОРАТОРИИ", "Батарейки", "Коробки", "ДискиCD", "ДискиDVD", "Видеокассеты", "5557682", "5939944", "5939945", "5942737", "5942736", "5256649", "Бумага офисная", "Бумага професиональная", "Бумага рулонная", "Бумага, пленка, лента", "Запчасти", "Зубные электрощетки", "Кинопленка", "Конверты", "Парные номера", "Плёнка", "Расходные материалы к фотокиоскам", "Скотч", "Тонеры", "Фотокиоски стационарные", "Химия", "Химия професиональная", "Плёнка професиональная", "Чернила", "Фотокниги (расходники)", "Широкоформатная струйная печать")
' перебираем все строки в используемом диапазоне листа
For Each ra In ActiveSheet.UsedRange.Rows
' перебираем все фразы в массиве
For Each word In УдалятьСтрокиСТекстом
' если в очередной строке листа найден искомый текст
If Not ra.Find(word, , xlValues, xlPart) Is Nothing Then
' добавляем строку в диапазон для удаления
If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
End If
Next word
Next
' если подходящие строки найдены, то: (оставьте одну из 2 следующих строк)
'If Not delra Is Nothing Then delra.EntireRow.Hidden = True ' скрываем их
If Not delra Is Nothing Then delra.EntireRow.Delete ' удаляем их
Call УдалениеБезОписания
End Sub
Sub УдалениеБезОписания()
Dim sSubStr As String
Dim lCol As Long
Dim lLastRow As Long, li As Long
sSubStr = ""
lCol = 20
If lCol = 0 Then Exit Sub
lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
For li = lLastRow To 1 Step -1
If CStr(Cells(li, lCol)) = sSubStr Then Rows(li).Delete
Next li
Call УдалениеБезЦены
End Sub
Sub УдалениеБезЦены()
Dim sSubStr As String
Dim lCol As Long
Dim lLastRow As Long, li As Long
sSubStr = ""
lCol = 13
If lCol = 0 Then Exit Sub
lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
For li = lLastRow To 1 Step -1
If CStr(Cells(li, lCol)) = sSubStr Then Rows(li).Delete
Next li
Call Количество
End Sub
Sub Количество()
Range("G1").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[1],'%'!R1C4:R13C5,2,0),"""")"
Selection.AutoFill Destination:=Range("G1:G20000")
Range("I1").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[1],'%'!R1C4:R13C5,2,0),"""")"
Selection.AutoFill Destination:=Range("I1:I20000")
Range("K1").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[1],'%'!R1C4:R13C5,2,0),"""")"
Selection.AutoFill Destination:=Range("K1:K20000")
Range("Q1").Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-10]+RC[-8]+RC[-6]),"""")"
Selection.AutoFill Destination:=Range("Q1:Q20000")
Columns("Q:Q").Select
Selection.Copy
Range("Q1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Call УдалитьЛишнее
End Sub
Sub УдалитьЛишнее()
Range("A:A,C:C,G:G,H:H,I:I,J:J,K:K,L:L,O:O,R:R,S:S,U:U,V: V,W:W,X:X,Y:Y,Z:Z,AA:AA,AB:AB,AC:AC,AD:AD").Delete Shift:=xlToLeft
Call Формулы
End Sub
Sub Формулы()
Range("F1").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-1],'%'!R1C1:R96C2,2,2),"""")"
Selection.AutoFill Destination:=Range("F1:F20000")
Range("G1").Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-2]*RC[-1]),"""")"
Selection.AutoFill Destination:=Range("G1:G20000")
Columns("G:G").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("F1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=IFERROR((ROUNDUP(RC[1],0)),"""")"
Selection.AutoFill Destination:=Range("F1:F20000")
Range("F1:F20000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("E:E,G:G").Delete Shift:=xlToLeft
Call CSVImport
End Sub
Sub CSVImport()
CPath = ThisWorkbook.Path
ControlFile = ActiveWorkbook.Name
ImportFile = CPath + "" + "Export_nal.csv"
Workbooks.OpenText (ImportFile), DataType:=xlDelimited, _
TextQualifier:=xlTextQualifierNone, FieldInfo:=Array(1, 4), Local:=True
With ActiveSheet.Range("$C$1:$C$20000")
.Formula = .Value
End With
Columns("A:A").Select
Selection.Copy
Windows("Import.xlsm").Activate
Range("C1").Select
ActiveSheet.Paste
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Export_nal.csv").Activate
Range("D1").Select
ActiveSheet.Paste
Windows("Import.xlsm").Activate
Columns("E:F").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Export_nal.csv").Activate
Range("E1").Select
ActiveSheet.Paste
Call СравнениеЭкспортНаличия
End Sub
Sub СравнениеЭкспортНаличия()
Dim my_range As Range, my_filter As Integer, result As Variant
Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Y"
Selection.AutoFill Destination:=Range("B1:B20000")
Range("G1").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-6],R1C4:R20000C6,2,0),"""")"
Selection.AutoFill Destination:=Range("G1:G20000")
Range("H1").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-7],C[-4]:C[-3],2,0)),RC[-5],VLOOKUP(RC[-7],C[-4]:C[-3],2,0))"
Selection.AutoFill Destination:=Range("H1:H20000")
Range("H1:H20000").Select
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("G1").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-6],R1C4:R20000C6,3,0),""0"")"
Selection.AutoFill Destination:=Range("G1:G20000")
Range("H1").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-7]<=10,(1000),RC[-1])"
Selection.AutoFill Destination:=Range("H1:H20000")
Range("H1:H20000").Select
Selection.Copy
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("E:E,F:F,G:G,H:H").Delete Shift:=xlToLeft
Application.CutCopyMode = False
With ActiveSheet.Range("$D$1:$D$20000")
.Formula = .Value
End With
Dim sSubStr As String
Dim lCol As Long
Dim lLastRow As Long, li As Long
sSubStr = ""
lCol = 1
If lCol = 0 Then Exit Sub
lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
For li = lLastRow To 1 Step -1
If CStr(Cells(li, lCol)) = sSubStr Then Rows(li).Delete
Next li
'ExportToTextFile FName:="D:ImportExport" + CStr(Date) + "_NC.csv", Sep:=";", _
'SelectionOnly:=False, AppendData:=False
' ActiveWorkbook.Close SaveChanges:=False
Range("A1:D3000").Select
ExportToTextFile FName:="D:ImportExport" + CStr(Date) + "_NC1.csv", Sep:=";", _
SelectionOnly:=True, AppendData:=False
Range("A3001:D6000").Select
ExportToTextFile FName:="D:ImportExport" + CStr(Date) + "_NC2.csv", Sep:=";", _
SelectionOnly:=True, AppendData:=False
Range("A6001:D9000").Select
ExportToTextFile FName:="D:ImportExport" + CStr(Date) + "_NC3.csv", Sep:=";", _
SelectionOnly:=True, AppendData:=False
Range("A9001:D12000").Select
ExportToTextFile FName:="D:ImportExport" + CStr(Date) + "_NC4.csv", Sep:=";", _
SelectionOnly:=True, AppendData:=False
Range("A12001:D15000").Select
ExportToTextFile FName:="D:ImportExport" + CStr(Date) + "_NC5.csv", Sep:=";", _
SelectionOnly:=True, AppendData:=False
Range("A15001:D18000").Select
ExportToTextFile FName:="D:ImportExport" + CStr(Date) + "_NC6.csv", Sep:=";", _
SelectionOnly:=True, AppendData:=False
ExportToTextFile FName:="D:ImportExport" + CStr(Date) + "_NC7.csv", Sep:=";", _
SelectionOnly:=False, AppendData:=False
ActiveWorkbook.Close SaveChanges:=False
Call УдалитьНеУдалить
End Sub
Sub УдалитьНеУдалить()
Dim my_range As Range, my_filter As Integer, result As Variant
Range("D1").Select
ActiveCell.FormulaR1C1 = _
"=IF(COUNTIF(R1C3:R20000C3,RC[-2]),""Kill me"",""No Kill"")"
Selection.AutoFill Destination:=Range("D1:D20000")
Columns("D:D").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim ra As Range, delra As Range
' ищем и удаляем строки, содержащие заданный текст
' (можно указать сколько угодно значений, и использовать подстановочные знаки)
УдалятьСтрокиСТекстом = Array("Kill me")
' перебираем все строки в используемом диапазоне листа
For Each ra In ActiveSheet.UsedRange.Rows
' перебираем все фразы в массиве
For Each word In УдалятьСтрокиСТекстом
' если в очередной строке листа найден искомый текст
If Not ra.Find(word, , xlValues, xlPart) Is Nothing Then
' добавляем строку в диапазон для удаления
If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
End If
Next word
Next
If Not delra Is Nothing Then delra.EntireRow.Delete ' удаляем их
Dim sSubStr As String
Dim lCol As Long
Dim lLastRow As Long, li As Long
sSubStr = ""
lCol = 1
If lCol = 0 Then Exit Sub
lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
For li = lLastRow To 1 Step -1
If CStr(Cells(li, lCol)) = sSubStr Then Rows(li).Delete
Next li
iPath = "D:ImportExportFoto"
With CreateObject("Scripting.FileSystemObject")
If .FolderExists(iPath) = True Then
.GetFolder(iPath).Delete True
End If
End With
'End If
End Sub
Public Sub ExportToTextFile(FName As String, _
Sep As String, SelectionOnly As Boolean, _
AppendData As Boolean)
Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
On Error GoTo EndMacro:
FNum = FreeFile
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(48004).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
If AppendData = True Then
Open FName For Append Access Write As #FNum
Else
Open FName For Output Access Write As #FNum
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = Chr(34) & Chr(34)
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
Close #FNum
End Sub
Public Function fClear(rng As Range, fltr As Integer)
If fltr = 0 Then
MsgBox "Не найдено ни одной записи"
Rows("1:1").Select
ActiveSheet.AutoFilterMode = False
Else
rng.Select
Selection.Delete Shift:=xlUp
Rows("1:1").Select
ActiveSheet.AutoFilterMode = False
End If
End Function
Sub Import1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets.Add.Name = "WCE"
CPath = ThisWorkbook.Path
ControlFile = ActiveWorkbook.Name
ImportFile = CPath + "" + "WCE.csv"
Workbooks.OpenText (ImportFile), DataType:=xlDelimited, _
TextQualifier:=xlTextQualifierNone, FieldInfo:=Array(1, 4), Local:=True
Columns("A:F").Select
Selection.Copy
Workbooks("import.xlsm").Activate
Range("A1").Select
ActiveSheet.Paste
Workbooks("WCE.csv").Activate
Columns("J:N").Select
Selection.Copy
Workbooks("import.xlsm").Activate
Range("L1").Select
ActiveSheet.Paste
Call Категория
End Sub
Sub Категория()
Cells.Replace What:="TV/аудио техника", Replacement:="TV-аудио техника", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
Cells.Replace What:="DVD/Blu-ray плееры", Replacement:="DVD-Blu-ray плееры" _
, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat _
:=False, ReplaceFormat:=False
Cells.Replace What:="MP3/MP4 плееры", Replacement:="MP3-MP4 плееры", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
Cells.Replace What:="Лазерные ч/б", Replacement:="Лазерные ч.б", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="Элементы питания и медиа", Replacement:="Элементы питания и фонари", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="D:ImportExportFoto", Replacement:="" _
, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat _
:=False, ReplaceFormat:=False
'Cells.Replace What:="http://yugcontract.ua/img/products/*", Replacement:="" _
', LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat _
':=False, ReplaceFormat:=False
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("D:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("F:F").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(SEARCH(""*"",RC[1])),""/"","""")"
Selection.AutoFill Destination:=Range("B1:B500"), Type:=xlFillDefault
Range("D1").Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(SEARCH(""*"",RC[1])),""/"","""")"
Selection.AutoFill Destination:=Range("D1:D500"), Type:=xlFillDefault
Range("F1").Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(SEARCH(""*"",RC[1])),""/"","""")"
Selection.AutoFill Destination:=Range("F1:F500"), Type:=xlFillDefault
Range("H1").Select
ActiveCell.FormulaR1C1 = "=RC[-7]&RC[-6]&RC[-5]&RC[-4]&RC[-3]&RC[-2]&RC[-1]"
Selection.AutoFill Destination:=Range("H1:H500"), Type:=xlFillDefault
Columns("H:H").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:G").Select
Application.CutCopyMode = False
Selection.ClearContents
Call СравнениеКода
End Sub
Sub СравнениеКода()
Sheets(4).Select
Columns("B:B").Select
Selection.Copy
Sheets("WCE").Select
Range("A1").Select
ActiveSheet.Paste
Sheets(4).Select
Columns("A:A").Select
Selection.Copy
Sheets("WCE").Select
Range("B1").Select
ActiveSheet.Paste
Sheets(4).Select
Columns("E:E").Select
Selection.Copy
Sheets("WCE").Select
Range("C1").Select
ActiveSheet.Paste
Sheets(4).Select
Columns("F:F").Select
Selection.Copy
Sheets("WCE").Select
Range("D1").Select
ActiveSheet.Paste
Range("E1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[4],C[-4]:C[-2],3,0)),"""",VLOOKUP(RC[4],C[-4]:C[-2],3,0))"
Selection.AutoFill Destination:=Range("E1:E500"), Type:=xlFillDefault
Range("F1").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[3],C[-5]:C[-4],2,0)),"""",VLOOKUP(RC[3],C[-5]:C[-4],2,0))"
Selection.AutoFill Destination:=Range("F1:F500"), Type:=xlFillDefault
Range("G1").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[2],C[-6]:C[-3],4,0)),"""",VLOOKUP(RC[2],C[-6]:C[-3],4,0))"
Selection.AutoFill Destination:=Range("G1:G500"), Type:=xlFillDefault
Columns("E:G").Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A:A,B:B,C:C,D:D").Select
Selection.Delete Shift:=xlToLeft
Call Описание
End Sub
Sub Описание()
Range("I1").Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(SEARCH(""*"",RC[1])),""||||Характеристика::"","""")"
Selection.AutoFill Destination:=Range("I1:I500"), Type:=xlFillDefault
Range("K1").Select
ActiveCell.FormulaR1C1 = "=RC[-3]&RC[-2]&RC[-1]"
Selection.AutoFill Destination:=Range("K1:K500"), Type:=xlFillDefault
Call Чистка
End Sub
Sub Чистка()
Dim sSubStr As String
Dim lCol As Long
Dim lLastRow As Long, li As Long
sSubStr = ""
lCol = 1
If lCol = 0 Then Exit Sub
lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
For li = lLastRow To 1 Step -1
If CStr(Cells(li, lCol)) = sSubStr Then Rows(li).Delete
Next li
Call УдалениеЭнтеров
End Sub
Sub УдалениеЭнтеров()
Workbooks("WCE.csv").Activate
Columns("H:I").Select
Cells.Replace What:=Chr(10), Replacement:="", LookAt:=xlPart
Call УдалениеПробелов
End Sub
Sub УдалениеПробелов()
Workbooks("WCE.csv").Activate
Columns("H:I").Select
Dim a As Range
For Each a In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConst ants).Areas
a = Application.Trim(a)
Next
Call Характеристика
End Sub
Sub Характеристика()
Workbooks("WCE.csv").Activate
Columns("G:H").Select
Selection.Copy
Workbooks("import.xlsm").Activate
Columns("G:H").Select
ActiveSheet.Paste
Workbooks("WCE.csv").Activate
Columns("I:I").Select
Selection.Copy
Workbooks("import.xlsm").Activate
Columns("J:J").Select
ActiveSheet.Paste
Columns("K:K").Select
Selection.Copy
Range("K1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("H:J").Select
Selection.Delete Shift:=xlToLeft
Workbooks("WCE.csv").Activate
Workbooks("WCE.csv").Close SaveChanges:=False
Call НовыйТовар
End Sub
Sub НовыйТовар()
CPath = ThisWorkbook.Path
ControlFile = ActiveWorkbook.Name
ImportFile = CPath + "" + "Import_CSV.csv"
Workbooks.OpenText (ImportFile), DataType:=xlDelimited, _
TextQualifier:=xlTextQualifierNone, FieldInfo:=Array(1, 4), Local:=True
Cells.Select
Selection.ClearContents
Workbooks("import.xlsm").Activate
Range("E:E").Select
Selection.Copy
Workbooks("Import_CSV.csv").Activate
Range("A1").Select
ActiveSheet.Paste
Workbooks("import.xlsm").Activate
Columns("F:F").Select
Selection.Copy
Workbooks("Import_CSV.csv").Activate
Range("B1").Select
ActiveSheet.Paste
Workbooks("import.xlsm").Activate
Columns("B:B").Select
Selection.Copy
Workbooks("Import_CSV.csv").Activate
Range("C1").Select
ActiveSheet.Paste
Workbooks("import.xlsm").Activate
Columns("A:A").Select
Selection.Copy
Workbooks("Import_CSV.csv").Activate
Range("D1").Select
ActiveSheet.Paste
Workbooks("import.xlsm").Activate
Columns("D:D").Select
Selection.Copy
Workbooks("Import_CSV.csv").Activate
Range("E1").Select
ActiveSheet.Paste
Range("F1").Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(SEARCH(""*"",RC[-1])),""Y"","""")"
Selection.AutoFill Destination:=Range("F1:F500")
Columns("F:F").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("import.xlsm").Activate
Columns("I:I").Select
Selection.Copy
Workbooks("Import_CSV.csv").Activate
Range("G1").Select
ActiveSheet.Paste
Workbooks("import.xlsm").Activate
Columns("I:I").Select
Selection.Copy
Workbooks("Import_CSV.csv").Activate
Range("H1").Select
ActiveSheet.Paste
Workbooks("import.xlsm").Activate
Columns("G:G").Select
Selection.Copy
Workbooks("Import_CSV.csv").Activate
Range("I1").Select
ActiveSheet.Paste
Workbooks("import.xlsm").Activate
Columns("H:H").Select
Selection.Copy
Workbooks("Import_CSV.csv").Activate
Range("J1").Select
ActiveSheet.Paste
Workbooks("import.xlsm").Activate
Columns("C:C").Select
Selection.Copy
Workbooks("Import_CSV.csv").Activate
Range("K1").Select
ActiveSheet.Paste
Workbooks("import.xlsm").Activate
Range("A:A,B:B,C:C,F:F,G:G,H:H,I:I").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Copy
Columns("A:A").Select
ActiveSheet.Paste
Dim sSubStr As String
Dim lCol As Long
Dim lLastRow As Long, li As Long
sSubStr = ""
lCol = 3
If lCol = 0 Then Exit Sub
lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
For li = lLastRow To 1 Step -1
If CStr(Cells(li, lCol)) = sSubStr Then Rows(li).Delete
Next li
Call ДопФото
End Sub
Sub ДопФото()
Dim sh As Worksheet, cell As Range, ra As Range: Application.ScreenUpdating = False
Set sh = ActiveSheet ' обрабатываем только активный лист
' диапазон заполненных ячеек в столбце А, начиная с A1
Set ra = sh.Range(sh.[A1], sh.Range("A" & sh.Rows.Count).End(xlUp))
For Each cell In ra.Cells ' перебираем все ячейки диапазона
' формируем путь к новому файлу
Путь = "D:ImportExportFoto" & _
"" & Replace_symbols(cell) & ""
N = 100 / ra.Cells.Count:
s1 = D * N + 1
s2 = (D + 1) * N
D = D + 1
CreateFolderWithSubfolders Путь ' создаём папку
КолвоСсылок = cell.EntireRow.Cells(sh.Columns.Count).End(xlToLef t).Column - 2
If КолвоСсылок < 0 Then КолвоСсылок = 0
' перебираем все ссылки
For i = 3 To cell.EntireRow.Cells(sh.Columns.Count).End(xlToLef t).Column
ИмяФайла = Путь & Replace_symbols(cell.Next) & "_" & (i - 2) & ".jpg"
Ссылка = cell.EntireRow.Cells(i).Text
Debug.Print ИмяФайла, Ссылка
' сохраняем очередную ссылку в виде файла в нужную папку
If DownLoadFile(Ссылка, ИмяФайла) Then
'Debug.Print "Скачан файл: " & Ссылка
'Else
'MsgBox "Не удалось загрузить файл " & Ссылка, vbCritical
End If
Next i
Next cell
Call ПересохранениеNC
End Sub
Sub ПересохранениеNC()
Kill "D:Importpprice_list.xls"
Kill "D:ImportWCE.csv"
Kill "D:ImportExport_nal.csv"
Call УдаляемВсе
End Sub
Sub УдаляемВсе()
Sheets("WCE").Select
ActiveWindow.SelectedSheets.Delete
Sheets(3).Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveWorkbook.Close SaveChanges:=False
End Sub
Powered by vBulletin® Version 4.2.2 Copyright © 2024 vBulletin Solutions, Inc. All rights reserved. Перевод: zCarot