Охотничий интернет-магазин?

**Kabansan** · 17.09.2014, 00:20

К сожалению Денис прав.

**GolDen** · 01.12.2014, 15:36

Цитата: Сообщение от Кирюха

Все нормально, флудите, много интересного может из этого получится.

вот у меня макрос, который подготавливает файл для заливки на сайт обновленного наличие и цены на существующий товар + подготавливает файл заливки нового товара
[CODE]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

[/CODE]

**GolDen** · 07.09.2016, 09:23

Никому не надо????))))

http://www.olx.ua/obyavlenie/prodam-...a-IDlSKRM.html

Тема: Охотничий интернет-магазин?

Опции темы

Отображение

Ваши права