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, а так же убирать значение в скобках, а оставшиеся символы разделять опять же по колонкам. Суть проблемы в том что в колонке "Задания с кратким ответом" помимо знаков + и - есть числа и макрос заменяит хи тоже. Вопрос - как сделать так что бы макрос не заменял числа, а просто разделял их на столбцы. Файл прикрепил
Всем добрый день, имеется макрос.
[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
Сообщение отредактировал Fasw11 - Вторник, 10.07.2018, 15:18