Добрый день, уважаемые форумчане!) Имеются данные в столбце А в формате, как в примере. Нужно, чтобы в случае, если в ячейке написано НЕТ, то ячейка не обрабатывалась, а если там есть цифры, то нужно каждый набор из 16 цифр разнести в ячейки на Листе2, как на примере. Строк в самом файле около 10000.
P.S. файл не могу выложить, т.к. на работе нет возможности выгружать файлы, поэтому пример разместил на облаке... Знаю, что по правилам нельзя, но прошу понять и простить... :(
Пример:
удален администрацией [moder]Не, Правила для всех одинаковы
Добрый день, уважаемые форумчане!) Имеются данные в столбце А в формате, как в примере. Нужно, чтобы в случае, если в ячейке написано НЕТ, то ячейка не обрабатывалась, а если там есть цифры, то нужно каждый набор из 16 цифр разнести в ячейки на Листе2, как на примере. Строк в самом файле около 10000.
P.S. файл не могу выложить, т.к. на работе нет возможности выгружать файлы, поэтому пример разместил на облаке... Знаю, что по правилам нельзя, но прошу понять и простить... :(
Пример:
удален администрацией [moder]Не, Правила для всех одинаковыjurafenix
Сообщение отредактировал _Boroda_ - Среда, 23.12.2015, 09:28
Sub Digit16() Dim i As Long Dim j As Integer Dim n As Long Dim iLastRow As Long Dim MyArr iLastRow = Cells(Rows.Count, 1).End(xlUp).Row n = 1 Sheets("Лист2").Cells.ClearContents For i = 1 To iLastRow If Cells(i, 1) <> "НЕТ" Then MyArr = Split(Cells(i, 1), Chr(10)) With Sheets("Лист2") For j = 0 To UBound(MyArr) .Cells(n, 1) = Mid(MyArr(j), 1, 16) n = n + 1 Next End With End If Next End Sub
[/vba]
В модуль Лист1 [vba]
Код
Sub Digit16() Dim i As Long Dim j As Integer Dim n As Long Dim iLastRow As Long Dim MyArr iLastRow = Cells(Rows.Count, 1).End(xlUp).Row n = 1 Sheets("Лист2").Cells.ClearContents For i = 1 To iLastRow If Cells(i, 1) <> "НЕТ" Then MyArr = Split(Cells(i, 1), Chr(10)) With Sheets("Лист2") For j = 0 To UBound(MyArr) .Cells(n, 1) = Mid(MyArr(j), 1, 16) n = n + 1 Next End With End If Next End Sub
А у меня получился код не такой привлекательный как у Kuzmich, (ибо я совсем не знаком с этой интересной ф-ей Split, терь буду знать, спасибо Kuzmich) код в общий модуль [vba]
Код
Sub Нет() Dim i&, i_n&, k&, k1&, s& Dim tabl() As String, tabl2() As String Dim MyArr i_n = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row ReDim tabl(i_n) For i = 1 To i_n tabl(i) = Replace(Worksheets(1).Cells(i, 1), " ", "") Next i For i = 1 To i_n If InStr(tabl(i), Chr(13)) > 0 Then s1 = 0 For s = 1 To Len(tabl(i)) If InStr(Right(tabl(i), Len(tabl(i)) - s), Chr(13)) > 0 Then k = k + 1 ReDim Preserve tabl2(k) Slovo = Right(tabl(i), Len(tabl(i)) - s - 1) Slovo1 = InStr(Right(tabl(i), Len(tabl(i)) - s), Chr(13)) tabl2(k) = Left(Right(tabl(i), Len(tabl(i)) - s1), InStr(Right(tabl(i), Len(tabl(i)) - s1), Chr(13))) s1 = s1 + InStr(Right(tabl(i), Len(tabl(i)) - s1), Chr(13)) s = s1 Else If s < Len(tabl(i)) Then k = k + 1 ReDim Preserve tabl2(k) tabl2(k) = Left(Right(tabl(i), Len(tabl(i)) - s1), Len(tabl(i))) Exit For End If End If Next s End If Next i For i = 1 To k tabl2(i) = Replace(Replace(tabl2(i), Chr(10), ""), Chr(13), "") Worksheets(2).Cells(i, 1).NumberFormat = "@" Worksheets(2).Cells(i, 1).Value = tabl2(i) Next i End Sub
[/vba] Меня несколько удивляет, что без строки [vba]
Код
Worksheets(2).Cells(i, 1).NumberFormat = "@"
[/vba] результат выводимый получается неправильный.... не пойму откуда такое).
А у меня получился код не такой привлекательный как у Kuzmich, (ибо я совсем не знаком с этой интересной ф-ей Split, терь буду знать, спасибо Kuzmich) код в общий модуль [vba]
Код
Sub Нет() Dim i&, i_n&, k&, k1&, s& Dim tabl() As String, tabl2() As String Dim MyArr i_n = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row ReDim tabl(i_n) For i = 1 To i_n tabl(i) = Replace(Worksheets(1).Cells(i, 1), " ", "") Next i For i = 1 To i_n If InStr(tabl(i), Chr(13)) > 0 Then s1 = 0 For s = 1 To Len(tabl(i)) If InStr(Right(tabl(i), Len(tabl(i)) - s), Chr(13)) > 0 Then k = k + 1 ReDim Preserve tabl2(k) Slovo = Right(tabl(i), Len(tabl(i)) - s - 1) Slovo1 = InStr(Right(tabl(i), Len(tabl(i)) - s), Chr(13)) tabl2(k) = Left(Right(tabl(i), Len(tabl(i)) - s1), InStr(Right(tabl(i), Len(tabl(i)) - s1), Chr(13))) s1 = s1 + InStr(Right(tabl(i), Len(tabl(i)) - s1), Chr(13)) s = s1 Else If s < Len(tabl(i)) Then k = k + 1 ReDim Preserve tabl2(k) tabl2(k) = Left(Right(tabl(i), Len(tabl(i)) - s1), Len(tabl(i))) Exit For End If End If Next s End If Next i For i = 1 To k tabl2(i) = Replace(Replace(tabl2(i), Chr(10), ""), Chr(13), "") Worksheets(2).Cells(i, 1).NumberFormat = "@" Worksheets(2).Cells(i, 1).Value = tabl2(i) Next i End Sub
[/vba] Меня несколько удивляет, что без строки [vba]
Код
Worksheets(2).Cells(i, 1).NumberFormat = "@"
[/vba] результат выводимый получается неправильный.... не пойму откуда такое).Roman777