Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
If Not Intersect(Target, Range("A2")) Is Nothing Then
On Error Resume Next
With ActiveSheet
.Outline.ShowLevels RowLevels:=3
.ShowAllData
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
.Range("A9:E" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Range("A1").CurrentRegion, Unique:=False
End With
End If
End Sub
Евгений Смирнов, если строк будет меньше, чем kRow = 3000 (например, 100), то файл не сохранится и не появится в папке P.S. Так же в каждый файл в конце добавляется пустая строка (vbNewLine), некоторым системам она будет мешать (строка пустая есть, а данных в ней нет)
P.P.S. С твоего разрешения
Код
Sub ExportToCSV_UTF8()
Dim arrData As Variant
Dim sPath As String, sSymbol As String, sFileName As String, sStr As String
Dim QtyOfRows As Long, QtyOfCols As Long, LimitRows As Long, RowsCounter As Long, i As Long, j As Long
sPath = ThisWorkbook.Path & "\"
LimitRows = 3000 'ActiveSheet.Rows.Count
sSymbol = "|"
arrData = ActiveSheet.UsedRange.Value
QtyOfRows = UBound(arrData, 1)
QtyOfCols = UBound(arrData, 2)
RowsCounter = LimitRows
If QtyOfRows >= LimitRows Then
sFileName = "1" & "_to_" & RowsCounter & ".csv"
Else
sFileName = "1" & "_to_" & QtyOfRows & ".csv"
End If
With CreateObject("ADODB.Stream")
.Open
.Charset = "UTF-8"
For i = 1 To QtyOfRows
For j = 1 To QtyOfCols
sStr = CStr(arrData(i, j))
If j <> QtyOfCols Then
.WriteText sStr & sSymbol
Else
If i Mod LimitRows = 0 Or i = QtyOfRows Then
.WriteText sStr 'последняя строка в файле: не добавляем vbNewLine
Else
.WriteText sStr & vbNewLine
End If
End If
Next j
If i = RowsCounter Or i = QtyOfRows Then 'сохранить файл, если достигли конца массива
.SaveToFile sFileName, 2
.Close
If RowsCounter + LimitRows < QtyOfRows Then
RowsCounter = RowsCounter + LimitRows
Else
LimitRows = QtyOfRows - RowsCounter
RowsCounter = QtyOfRows
End If
sFileName = RowsCounter - LimitRows + 1 & "_to_" & RowsCounter & ".csv"
If i <> QtyOfRows Then .Open
End If
Next i
End With
MsgBox "Файлы сохранены в папку: " & sPath, vbInformation, "CSV"
End Sub
Sub ExportToCSV_UTF8()
'CSV в кодировке UTF8+BOM
Dim wb As Workbook
Dim ws As Worksheet
Dim sSymbol As String, txt As String
Dim i As Long, j As Long, RowsLimit As Long
Dim arr(), arr2()
If MsgBox("Сохранить лист в CSV?", vbQuestion + vbYesNo, "Вопросы") = vbNo Then Exit Sub
sSymbol = "|" 'символ-разделитель
RowsLimit = 3000 'кол-строк строк в 1 файле
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set ws = ActiveWorkbook.Worksheets("Итоговые цены")
arr = ws.UsedRange.Value
For i = LBound(arr, 1) To UBound(arr, 1)
ReDim Preserve arr2(i - 1)
For j = LBound(arr, 2) To UBound(arr, 2)
If txt = "" Then
txt = arr(i, j)
Else
txt = txt & sSymbol & arr(i, j)
End If
Next j
arr2(i - 1) = Replace$(txt, Chr(34), "")
txt = ""
Next i
For i = LBound(arr2) To UBound(arr2) Step RowsLimit
Set wb = Workbooks.Add
For j = i To i + (RowsLimit - 1)
If j > UBound(arr2) Then Exit For
wb.Worksheets(1).Cells(j - i + 1, 1).Value = arr2(j)
Next j
wb.SaveAs "d:\Clouds\Yandex.Disk\Магазин\pricelists\import\" & "Prices_marketplaces_from_" & i & "_to_" & i + RowsLimit & ".csv", xlCSVUTF8
wb.Close False
Next i
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Готово", vbInformation, "Конец"
End Sub
любой PQ'шник скажет - переводите данные (храните данные) в TXT формате - а забирать данные из TXT файла можно через Power Query и потом строить сводные, графики и т.д.
я так подозреваю, что на каком-то листе у вас есть кнопка, на которую привязан макрос и вы этой строкой пытаетесь нажать эту кнопку с нужным макросом. Может вам проще будет на пытаться макросом нажать эту кнопку, а просто запустить нужный макрос, вы же знаете его название, например,
да, но новичок не обратит внимание на точку с запятой, поэтому новичкам лучше всегда указывать 4-й аргумент в обязательном порядке для новичков эти 2 формулы одинаковые
и раз вы "совсем не эксперт в Excel", то запомните, что у функции ВПР для вас (как не эксперта) не 3, а 4 аргумента, и в 4-м аргументе Вам всегда нужно указывать число 0 (или слово ЛОЖЬ), иначе вас в жизни ждут большие перемены - штрафы от начальства за ошибки в таблице, а может и увольнение...
PaxomGG, вместо цитирования всего сообщения (которое ни вам ни нам не нужно), вы можете нажимать кнопку "Имя", которая находится на 1 см правее от кнопки "Цитировать"
Sub ReplaceURL()
Dim arrB As Variant, arrC As Variant, arrI As Variant, arrJ As Variant
Dim LastRow As Long, i As Long, n As Long
Dim sURL As String
With ActiveSheet
If .FilterMode = True Then .ShowAllData
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
arrB = .Range("B2:B" & LastRow).Value
arrC = .Range("C2:C" & LastRow).Value
arrI = .Range("I2:I" & LastRow).Value
arrJ = .Range("J2:J" & LastRow).Value
For i = LBound(arrB) To UBound(arrB)
sURL = arrB(i, 1)
For n = LBound(arrI) To UBound(arrI)
If LCase(sURL) = LCase(arrI(n, 1)) Then
arrC(i, 1) = arrJ(n, 1)
Exit For
End If
Next n
Next i
.Range("C2").Resize(UBound(arrC), 1).Value = arrC
End With
MsgBox "Готово!", vbInformation, "Конец"
End Sub
на самом деле это ваш комп что-то делает не так. вот копируем текст из TXT, вставляем его в ячейку - да, визуально TAB не видно, но он там есть. Посмотрите номер 3-го символа в ячейке. Это код символа 9, т.е. TAB. А вот ваш комп почему-то заменяет символ TAB (9), на пробел (символ 32) То, что у пользователя есть TAB в ячейке вы можете сами убедится встав в ячейку с текстом и нажать F2 - текст в ячейке разделится по TAB
P.S. Пусть клиент вставляет скопированный текст не заходя внутрь ячейки - получится 2 столбца - в 1м будет номер трека, а во 2м столбце будет его название P.P.S. У меня Office 365 и вставляется так же, как и у вашего пользователя - когда вставляешь текст - TAB не виден в ячейке, но если нажать F2 - весь текст форматируется через TAB и 3-й символ в ячейке код символа 9 (TAB). А вот в вашем "Хорошем" файле - 3-й символ пробел (32-й код). Откуда он у вас берётся пробел, если в текстовом файле 3-й символ это TAB (код 9) ?
Ваши коллеги тащат какую-то информацию из базы MySQL и потом отправляют файл вам. В этом файле скорее всего есть скрытое имя "LOCAL_MYSQL_DATE_FORMAT" (вы его глазами не видите). Когда вы копируете лист, то вместе с этим листом вы копируете и имя, вот Excel и ругается, что вы пытаетесь задвоить имя. попробуйте перед копированием листа запустить этот макрос
Код
Sub DeleteName()
Dim nName As Name
On Error Resume Next
For Each nName In ActiveWorkbook.Names
If nName.Name = "LOCAL_MYSQL_DATE_FORMAT" Then nName.Delete
Next nName
For Each nName In ActiveSheet.Names
If nName.Name = "LOCAL_MYSQL_DATE_FORMAT" Then nName.Delete
Next nName
On Error GoTo 0
End Sub
Private Sub Workbook_Open()
Dim UserResponse As VbMsgBoxResult
If Application.Calculation = xlCalculationManual Then
If MsgBox("В книге установлен ручной пересчёт формул!" & vbLf & "Включить автоматический пересчёт?", vbQuestion + vbYesNo, "Внимание") = vbYes Then
Application.Calculation = xlCalculationAutomatic
End If
End If
End Sub
Private Sub Workbook_Open()
If Application.Calculation = xlCalculationManual Then
MsgBox "В книге установлен ручной пересчёт формул!" & vbLf & "Если нужен автоматический, то меню Формулы - Параметры вычислений", vbExclamation, "Внимание"
End If
End Sub