Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Excel функция сжимании цифр и убрать запятые лишние, исправить функцию сжатия цифр
 
#1
27.05.2016 12:07:29
Нужно цифры, которые есть в столбце и считаются путем сжатия исправить в функции следующее
1) соединять в тире только если три и более, в количестве двух и одного не соединять через тире
пример 1, 2, 4-7, 11, 12, 22-45
2) убрать в конце лишние пробелы и запятые

Код
Function Sgatie(диапазон As Range) As String
Dim i&, j&, a()
a = диапазон.Value
j = 1: Sgatie = a(1, 1)
For i = 2 To UBound(a, 1)
  If a(i, 1) = a(i - 1, 1) + 1 Then
    j = j + 1
  ElseIf j = 1 Then
      Sgatie = Sgatie & ", " & a(i, 1)
    Else
      j = 1
      Sgatie = Sgatie & "-" & a(i - 1, 1) & ", " & a(i, 1)
  End If
Next
If j > 1 Then Sgatie = Sgatie & "-" & a(i - 1, 1)
End Function
Изменено: next777pro - 27.05.2016 12:09:53
 
 
 
#2
27.05.2016 12:40:55
Код
Function Sgatie(диапазон As Range) As String
Dim i&, j&, a()
a = диапазон.Value
j = 1: Sgatie = a(1, 1)
For i = 2 To UBound(a, 1)
  If a(i, 1) = a(i - 1, 1) + 1 Then
    j = j + 1
  ElseIf j = 1 Then
        If ", " & a(i, 1) <> ", " Then Sgatie = Sgatie & ", " & a(i, 1)
    Else
      j = 1
      If "-" & a(i - 1, 1) & ", " & a(i, 1) <> ", " Then Sgatie = Sgatie & "-" & a(i - 1, 1) & ", " & a(i, 1)
  End If
Next
If j > 1 Then Sgatie = Sgatie & "-" & a(i - 1, 1)
End Function
 
 
 
#3
27.05.2016 12:51:03
убрались запятые
а это не решилось
2-3,   5, 8, 10, 12-14, 16, 22
здесь так нужно 2, 3, 5, 8, 10. 12-14, 16, 22
 
 
 
#4
27.05.2016 12:57:09
Цитата
CrazyRabbit написал: Function Sgatie(диапазон As Range) As String
не полностью решилось
2-3,   5, 8, 10, 12-14, 16, 22, 25-26,
в таких случаях запятая в конце еще висит, если в конце через тире соединено
2, 3, 5, 8, 10, 12-14, 16, 22, 25, 26 здесь будет правильным, это как сделать
Изменено: next777pro - 28.05.2016 00:15:10
 
 
 
#5
27.05.2016 14:16:22
Вроде так должно работать
Код
Function Sgatie(диапазон As Range) As String
Dim i&, j&, a()
a = диапазон.Value
j = 1: Sgatie = a(1, 1)
y = a(1, 1)
For i = 2 To UBound(a, 1)
  If a(i, 1) = a(i - 1, 1) + 1 Then
    j = j + 1
  ElseIf j = 1 Then
        If ", " & a(i, 1) <> ", " Then
          Sgatie = Sgatie & ", " & a(i, 1)
          y = a(i, 1)
        End If
    Else
      j = 1
      If y + 1 = a(i - 1, 1) Then
        Sgatie = Sgatie & ", " & a(i - 1, 1) & ", " & a(i, 1)
      Else
        Sgatie = Sgatie & "-" & a(i - 1, 1) & ", " & a(i, 1)
      End If
  End If
Next
If j > 1 Then Sgatie = Sgatie & "-" & a(i - 1, 1)
End Function
 
 
 
#6
28.05.2016 08:20:44
Цитата
CrazyRabbit написал:
Вроде так должно работать
Спасибо, но вот результат не совсем был радостным для однозначных, двухзначных и трехзначных как то странно разъединяет два вместе
2, 3,   5, 8, 10, 12-14, 16, 22, 25-27, 29-30, 32-33, 37, 39, 40, 101-102, 104-105,   1011-1012, 1112
неправильно через тире здесь 29, 30 и 32, 33 и 101, 102 также 104, 105 и еще 1011, 1012 так должно быть

хотя  для однозначных тоже самое
2, 3,   5, 8, 10, 12-14, 16, 22, 25-27, 29-30, 32-33, 37, 39, 40, 101-102, 104-105,   1011-1012, 1112, 1119, 1120, 9-10, 6-7,
9-10 и 6-7 вместе не правильно, они с запятыми должны быть 9, 10 и 6, 7

и если в конце стоит запятая, то как ее убрать
2, 3,   5, 8, 10, 12-14, 16, 22, 25-27,
Изменено: next777pro - 28.05.2016 10:56:54
 
 
 
#7
28.05.2016 14:58:34
Код
Function Sgatie(диапазон As Range) As String
    Dim a(), b()
    Dim i&, ii&, j&, jj&, x&, y&
'--------------------------------
    a = диапазон.Value
    For i = 1 To UBound(a)
        If a(i, 1) <> "" Then
            x = a(i, 1)
            y = 0: jj = 0
            For ii = i + 1 To UBound(a)
                jj = jj + 1
                If a(ii, 1) - x = jj Then
                    y = a(ii, 1)
                Else: Exit For
                End If
            Next
            j = j + 1
            ReDim Preserve b(1 To j)
            If y - x > 1 Then
                b(j) = x & "-" & y
                i = ii - 1
            Else:  b(j) = x
            End If
        End If
    Next
    Sgatie = Join(b, ", ")
End Function
Изменено: kalbasiatka - 29.05.2016 00:00:54
 
 
 
#8
28.05.2016 16:23:35
Цитата
kalbasiatka написал:
Function Sgatie(диапазон As Range) As String
близко, но чуть чуть не то
результат
2-3,   5, 8, 10, 12-14, 16, 22, 25-27, 29-30, 32-33, 37, 39-40, 101-102, 104-105,   1011-1012, 1112, 1119-1120, 9-10, 6-7
нужно сделать
2, 3,   5, 8, 10, 12-14, 16, 22, 25-27, 29, 30, 32, 33, 37, 39, 40, 101, 102, 104, 105,   1011, 1012, 1112, 1119, 1120, 9, 10, 6, 7
то есть если
если их два 2, 3, 6 то так и оставить 2, 3, 6
а если их три и более 2, 3, 4, 6 то сделать так 2-4, 6
Изменено: next777pro - 28.05.2016 16:35:37
 
 
 
#9
28.05.2016 17:40:22
такой?
Код
Function Sgatie(диапазон As Range) As String
    Dim i&, j&, a()
    a = диапазон.Value
    Dim tArr
    ReDim tArr(1 To UBound(a, 1), 1 To 3)
    For i = 1 To UBound(a, 1)
        tArr(i, 1) = a(i, 1)
        tArr(i, 2) = a(i, 1)
    Next
    
    Output = ""
    For i = 1 To UBound(a, 1)
        tArr(i, 1) = a(i, 1)
        tArr(i, 2) = a(i, 1)
        For y = i + 1 To UBound(tArr, 1)
            If tArr(i, 2) + 1 = tArr(y, 1) Then
                tArr(i, 2) = tArr(y, 1)
                tArr(y, 1) = 0
            Else
                i = y - 1: Exit For
            End If
        Next y
    Next i
    
    For i = 1 To UBound(tArr, 1)
        If tArr(i, 1) <> 0 Then
            If tArr(i, 1) = tArr(i, 2) Then
                Output = Output & tArr(i, 1) & ","
            ElseIf tArr(i, 1) = tArr(i, 2) - 1 Then
                Output = Output & tArr(i, 1) & "," & tArr(i, 2) & ","
            ElseIf tArr(i, 1) < tArr(i, 2) - 1 Then
                Output = Output & tArr(i, 1) & "-" & tArr(i, 2) & ","
            Else
                MsgBox ("Ошибка в формуле")
            End If
        End If
    Next i
    
    If Right(Output, 1) = "," Then
        Output = Mid(Output, 1, Len(Output) - 1)
    End If
    Sgatie = Output
End Function
 
 
 
#10
28.05.2016 18:42:03
Цитата
Zoynels написал:
Function Sgatie(диапазон As Range) As String
Вот молодец, решил идеально! Спасибо огромное
чуть чуть исправил
чтобы выходило с пробелами, так
1-4,   6-11, 13
Код
Function Sgatie(äèàïàçîí As Range) As String
    Dim i&, j&, a()
    a = äèàïàçîí.Value
    Dim tArr
    ReDim tArr(1 To UBound(a, 1), 1 To 3)
    For i = 1 To UBound(a, 1)
        tArr(i, 1) = a(i, 1)
        tArr(i, 2) = a(i, 1)
    Next
      
    Output = ""
    For i = 1 To UBound(a, 1)
        tArr(i, 1) = a(i, 1)
        tArr(i, 2) = a(i, 1)
        For y = i + 1 To UBound(tArr, 1)
            If tArr(i, 2) + 1 = tArr(y, 1) Then
                tArr(i, 2) = tArr(y, 1)
                tArr(y, 1) = 0
            Else
                i = y - 1: Exit For
            End If
        Next y
    Next i
      
    For i = 1 To UBound(tArr, 1)
        If tArr(i, 1) <> 0 Then
            If tArr(i, 1) = tArr(i, 2) Then
                Output = Output & tArr(i, 1) & ", "
            ElseIf tArr(i, 1) = tArr(i, 2) - 1 Then
                Output = Output & tArr(i, 1) & ", " & tArr(i, 2) & ", "
            ElseIf tArr(i, 1) < tArr(i, 2) - 1 Then
                Output = Output & tArr(i, 1) & "-" & tArr(i, 2) & ", "
            Else
                MsgBox ("Îøèáêà â ôîðìóëå")
            End If
        End If
    Next i
     
    If Right(Output, 1) = " " Then
        Output = Mid(Output, 1, Len(Output) - 1)
    End If
    If Right(Output, 1) = "," Then
        Output = Mid(Output, 1, Len(Output) - 1)
    End If
    Sgatie = Output
End Function
Изменено: next777pro - 28.05.2016 19:12:01
 
 
 
#11
28.05.2016 19:15:24
 кто поможет сократить в том же коде
Код
   If Right(Output, 1) = " " Then
        Output = Mid(Output, 1, Len(Output) - 1)
    End If
    If Right(Output, 1) = "," Then
        Output = Mid(Output, 1, Len(Output) - 1)
    End If
 
 
 
#12
28.05.2016 20:04:20
вариант 1: в мой код (последнюю запись заменить)
Код
Sgatie = Replace(Output, ",", ", ")
вариант 2: в ваш вариант кода
Код
    If Right(Output, 2) = ", " Then
        Output = Mid(Output, 1, Len(Output) - 2)
    End If
 
 
 
#13
29.05.2016 00:01:22
Поправил свой код выше.
 
 
 
#14
29.05.2016 00:13:16
спасибо всем, все проверю
 
 
 
#15
29.05.2016 00:21:42
Цитата
kalbasiatka написал:
Function Sgatie(диапазон As Range) As String
отлично
 
 
 
#16
29.05.2016 00:30:28
теперь у меня аж три функции идеальных) большое спасибо
 
 
 
#17
29.05.2016 00:40:04
Цитата
Zoynels написал:
вариант 1: в мой код (последнюю запись заменить)Код ? 1Sgatie = Replace(Output, ",", ", ")вариант 2: в ваш вариант кода
Благодарю за точность и усердие
Изменено: next777pro - 29.05.2016 00:40:33
 
 
 
Страницы: 1
Наверх