Всем привет. Нарыл макрос, который делит листы по условию на книги. Однако мне нужно адаптировать его: нужно условие брать из третьего столбца и лист у меня только один и данные у меня начинаются с 2 столбца,а не 3. файл пример во вложении.
[vba]
Код
Option Explicit Sub razdelit() Dim oDic As Object, arr(), arWB(), j As Long, wbOld As Workbook Dim sh As Worksheet, i As Long, cnt As Long, k As Long, wb As Workbook Set wbOld = ThisWorkbook For Each sh In Worksheets arr = sh.UsedRange.Value Set oDic = CreateObject("scripting.dictionary") For i = 3 To UBound(arr) oDic.Item(arr(i, 1)) = arr(i, 1) Next Next arWB = oDic.items Set oDic = Nothing ReDim arrData(1 To UBound(arr), 1 To UBound(arr, 2)) For i = 1 To UBound(arWB) Set wb = Workbooks.Add wb.SaveAs "D:\test" & "\" & arWB(i) & ".xlsx" 'ïóòü ñîõðàíåíèÿ ôàéëîâ Set wb = ActiveWorkbook For Each sh In wbOld.Worksheets cnt = 0 arr = sh.UsedRange.Value For j = 3 To UBound(arr) If arr(j, 1) = arWB(i) Then cnt = cnt + 1 For k = 1 To UBound(arr, 2) arrData(cnt, k) = arr(j, k) Next End If Next wb.Sheets.Add.Name = sh.Name wb.Sheets(sh.Name).[a1].Resize(cnt, UBound(arr, 2)) = arrData Next wb.Close True Next End Sub
[/vba]
Всем привет. Нарыл макрос, который делит листы по условию на книги. Однако мне нужно адаптировать его: нужно условие брать из третьего столбца и лист у меня только один и данные у меня начинаются с 2 столбца,а не 3. файл пример во вложении.
[vba]
Код
Option Explicit Sub razdelit() Dim oDic As Object, arr(), arWB(), j As Long, wbOld As Workbook Dim sh As Worksheet, i As Long, cnt As Long, k As Long, wb As Workbook Set wbOld = ThisWorkbook For Each sh In Worksheets arr = sh.UsedRange.Value Set oDic = CreateObject("scripting.dictionary") For i = 3 To UBound(arr) oDic.Item(arr(i, 1)) = arr(i, 1) Next Next arWB = oDic.items Set oDic = Nothing ReDim arrData(1 To UBound(arr), 1 To UBound(arr, 2)) For i = 1 To UBound(arWB) Set wb = Workbooks.Add wb.SaveAs "D:\test" & "\" & arWB(i) & ".xlsx" 'ïóòü ñîõðàíåíèÿ ôàéëîâ Set wb = ActiveWorkbook For Each sh In wbOld.Worksheets cnt = 0 arr = sh.UsedRange.Value For j = 3 To UBound(arr) If arr(j, 1) = arWB(i) Then cnt = cnt + 1 For k = 1 To UBound(arr, 2) arrData(cnt, k) = arr(j, k) Next End If Next wb.Sheets.Add.Name = sh.Name wb.Sheets(sh.Name).[a1].Resize(cnt, UBound(arr, 2)) = arrData Next wb.Close True Next End Sub