Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Разделение символов на столбцы VBA - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Разделение символов на столбцы VBA (Макросы/Sub)
Разделение символов на столбцы VBA
Fasw11 Дата: Понедельник, 09.07.2018, 15:26 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Всем добрый день, имеется макрос.

[vba]
Код
Option Base 1
Option Explicit
Sub РазнестиПоКолонкам()
Dim arrIn(), arrOut(), arrIn1(), arrOut1(), i As Long, j As Long, str
arrIn = Range("U2:U" & Cells(Rows.Count, 21).End(xlUp).Row).Value
arrIn1 = Range("W2:W" & Cells(Rows.Count, 23).End(xlUp).Row).Value
ReDim arrOut(1 To UBound(arrIn, 1), 1 To Len(arrIn(1, 1)))
ReDim arrOut1(1 To UBound(arrIn1, 1), 1 To Len(DS(arrIn1(1, 1))))
For i = LBound(arrIn, 1) To UBound(arrIn, 1)
arrIn1(i, 1) = DS(arrIn1(i, 1))
For j = LBound(arrOut, 2) To UBound(arrOut, 2)
If Not WorksheetFunction.IsNumber(Range("U2")) Then arrOut(i, j) = IIf(Mid(arrIn(i, 1), j, 1) = "+", 1, 0)
If Not WorksheetFunction.IsNumber(Range("W2")) Then
If j <= Len(DS(arrIn1(1, 1))) Then arrOut1(i, j) = Mid(arrIn1(i, 1), j, 1)
End If
Next j
Next i
If Not WorksheetFunction.IsNumber(Range("W2")) Then
str = Range("W1").Value
Columns("W:X").Delete Shift:=xlToLeft
For j = 1 To UBound(arrOut1, 2)
Columns("W:W").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Next j
Range("W1").Value = str
Range("W1").Resize(1, UBound(arrOut1, 2)).Merge
Range("W1").Resize(1, UBound(arrOut1, 2)).ColumnWidth = 3
Range("W2").Resize(UBound(arrOut1, 1), UBound(arrOut1, 2)).Value = arrOut1
End If
If Not WorksheetFunction.IsNumber(Range("U2")) Then
str = Range("U1").Value
Columns("U:V").Delete Shift:=xlToLeft
For j = 1 To UBound(arrOut, 2)
Columns("U:U").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Next j
Range("U1").Value = str
Range("U1").Resize(1, UBound(arrOut, 2)).Merge
Range("U1").Resize(1, UBound(arrOut, 2)).ColumnWidth = 2
Range("U2").Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
End If
End Sub
Function DS(ByVal strCurr As String) As String
strCurr = Replace(strCurr, "(0)", "")
strCurr = Replace(strCurr, "(1)", "")
strCurr = Replace(strCurr, "(2)", "")
strCurr = Replace(strCurr, "(3)", "")
strCurr = Replace(strCurr, "(4)", "")
strCurr = Replace(strCurr, "(5)", "")
strCurr = Replace(strCurr, "(6)", "")
strCurr = Replace(strCurr, "(7)", "")
strCurr = Replace(strCurr, "(8)", "")
strCurr = Replace(strCurr, "(9)", "")
DS = strCurr
End Function
[/vba]
По сути он должен разделять символы "+" и "-" по калонкам и заменять "+" на 1; "-"на 0, а так же убирать значение в скобках, а оставшиеся символы разделять опять же по колонкам. Суть проблемы в том что в колонке "Задания с кратким ответом" помимо знаков + и - есть числа и макрос заменяит хи тоже.
Вопрос - как сделать так что бы макрос не заменял числа, а просто разделял их на столбцы.
Файл прикрепил


Сообщение отредактировал Fasw11 - Вторник, 10.07.2018, 15:18
 
Ответить
СообщениеВсем добрый день, имеется макрос.

[vba]
Код
Option Base 1
Option Explicit
Sub РазнестиПоКолонкам()
Dim arrIn(), arrOut(), arrIn1(), arrOut1(), i As Long, j As Long, str
arrIn = Range("U2:U" & Cells(Rows.Count, 21).End(xlUp).Row).Value
arrIn1 = Range("W2:W" & Cells(Rows.Count, 23).End(xlUp).Row).Value
ReDim arrOut(1 To UBound(arrIn, 1), 1 To Len(arrIn(1, 1)))
ReDim arrOut1(1 To UBound(arrIn1, 1), 1 To Len(DS(arrIn1(1, 1))))
For i = LBound(arrIn, 1) To UBound(arrIn, 1)
arrIn1(i, 1) = DS(arrIn1(i, 1))
For j = LBound(arrOut, 2) To UBound(arrOut, 2)
If Not WorksheetFunction.IsNumber(Range("U2")) Then arrOut(i, j) = IIf(Mid(arrIn(i, 1), j, 1) = "+", 1, 0)
If Not WorksheetFunction.IsNumber(Range("W2")) Then
If j <= Len(DS(arrIn1(1, 1))) Then arrOut1(i, j) = Mid(arrIn1(i, 1), j, 1)
End If
Next j
Next i
If Not WorksheetFunction.IsNumber(Range("W2")) Then
str = Range("W1").Value
Columns("W:X").Delete Shift:=xlToLeft
For j = 1 To UBound(arrOut1, 2)
Columns("W:W").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Next j
Range("W1").Value = str
Range("W1").Resize(1, UBound(arrOut1, 2)).Merge
Range("W1").Resize(1, UBound(arrOut1, 2)).ColumnWidth = 3
Range("W2").Resize(UBound(arrOut1, 1), UBound(arrOut1, 2)).Value = arrOut1
End If
If Not WorksheetFunction.IsNumber(Range("U2")) Then
str = Range("U1").Value
Columns("U:V").Delete Shift:=xlToLeft
For j = 1 To UBound(arrOut, 2)
Columns("U:U").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Next j
Range("U1").Value = str
Range("U1").Resize(1, UBound(arrOut, 2)).Merge
Range("U1").Resize(1, UBound(arrOut, 2)).ColumnWidth = 2
Range("U2").Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
End If
End Sub
Function DS(ByVal strCurr As String) As String
strCurr = Replace(strCurr, "(0)", "")
strCurr = Replace(strCurr, "(1)", "")
strCurr = Replace(strCurr, "(2)", "")
strCurr = Replace(strCurr, "(3)", "")
strCurr = Replace(strCurr, "(4)", "")
strCurr = Replace(strCurr, "(5)", "")
strCurr = Replace(strCurr, "(6)", "")
strCurr = Replace(strCurr, "(7)", "")
strCurr = Replace(strCurr, "(8)", "")
strCurr = Replace(strCurr, "(9)", "")
DS = strCurr
End Function
[/vba]
По сути он должен разделять символы "+" и "-" по калонкам и заменять "+" на 1; "-"на 0, а так же убирать значение в скобках, а оставшиеся символы разделять опять же по колонкам. Суть проблемы в том что в колонке "Задания с кратким ответом" помимо знаков + и - есть числа и макрос заменяит хи тоже.
Вопрос - как сделать так что бы макрос не заменял числа, а просто разделял их на столбцы.
Файл прикрепил

Автор - Fasw11
Дата добавления - 09.07.2018 в 15:26
Pelena Дата: Понедельник, 09.07.2018, 20:18 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19162
Репутация: 4412 ±
Замечаний: ±

Excel 365 & Mac Excel
Fasw11, эту строчку[vba]
Код
If Not WorksheetFunction.IsNumber(Range("U2")) Then arrOut(i, j) = IIf(Mid(arrIn(i, 1), j, 1) = "+", 1, 0)
[/vba]поменяйте на
[vba]
Код
If Not WorksheetFunction.IsNumber(Range("U2")) Then arrOut(i, j) = IIf(Mid(arrIn(i, 1), j, 1) = "+", 1, IIf(Mid(arrIn(i, 1), j, 1) = "-", 0, Mid(arrIn(i, 1), j, 1)))
[/vba]


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеFasw11, эту строчку[vba]
Код
If Not WorksheetFunction.IsNumber(Range("U2")) Then arrOut(i, j) = IIf(Mid(arrIn(i, 1), j, 1) = "+", 1, 0)
[/vba]поменяйте на
[vba]
Код
If Not WorksheetFunction.IsNumber(Range("U2")) Then arrOut(i, j) = IIf(Mid(arrIn(i, 1), j, 1) = "+", 1, IIf(Mid(arrIn(i, 1), j, 1) = "-", 0, Mid(arrIn(i, 1), j, 1)))
[/vba]

Автор - Pelena
Дата добавления - 09.07.2018 в 20:18
Fasw11 Дата: Вторник, 10.07.2018, 11:06 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Pelena, спасибо огромное ))
 
Ответить
СообщениеPelena, спасибо огромное ))

Автор - Fasw11
Дата добавления - 10.07.2018 в 11:06
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Разделение символов на столбцы VBA (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!