Как в Excel c помощью VBA найти ячейку и преобразвать её?

[Lexales]

Есть ячейки с временим( формат 10:15-11:30), текстовые ячейки.
Мне надо найти ячейку с временем и перевести время на 8 часов вперед. Потом взять ячейку с текстом и поставить напротив времени(с этим я справлюсь). Но вот как най ти ячейки с временем!!!! До меня не доходит. Подскажите, плиз!!!! Если можно с пояснениями. Заранее спасибо!

[SergeySV2]

Тебе нужен метод Worksheets(...).Range(....).Find, описание посмотри в справке

[Lexales]

Это я знаю. Напишу пример.
Есть строка:
10:20-11:30
Вести-спорт
Надо:
17:20-18:30 Вести-спорт

И так далее.Это обыкновенная Тв программа. но каждый раз ее форматировать в ручную, это не реально.Подскажите как можно это реализовать.
И еще:
Есть строки:

Rugby on SuperSport: Wednesday 12 January
Time Channel Details
11:00 - 12:00 SS1 H/L: Rd 5 - Ulster vs Gloucester

Надо:
12 января
19:00-20:00 рэгби H/L: Rd 5 - Ulster vs Gloucester SS1
И что по этому примеру подскажите. ОСОБЕННО как вытащить из строки Rugby on SuperSport: Wednesday 12 January, вид спорта и дату.

[SergeySV2]

Ну у меня была чем-то похожая задача - я анализировал тект приходящих писем, весь текст письма я получал запиханным в одну переменную String. Зная ключевые слова (или их варианты), а также крайнюю границу (до первого пробела, до перевода строки, до символа и т.д.) занимаешься извлечением данных с помощью функций: InStr, Mid, Left, Right

Главное так сказать определиться с реперными точками, т.е. после каких символов идет интерующая тебя информация, всегда ли она в таком виде?, т.е. надо искать что-то в постоянное, к чему можно привязаться...

Например в втоем случае - время можно искать по наличию в строке комбин. символов ":** - **:" ('*' - это обозначает что тут может быть любой символ) и потом вырезать соответственно с i-2 по i+10 (i-номер вхождения). Вообщем, работа кропотливая, со временем ты наваяещь себе уже спец. функции, которые будут выцеплять нужную тебе информацию.

За время моей работы, у меня накопилась например следующая коллекция вспомогательных функций по работе с текстов. строками:

Код: Выделить всё

Public Function InStrMask(start As Integer, string1 As String, string2 As String, compare As MyCompare, begORendPos As Boolean) As String
  ' работает как и функ. InStr только с возможностью указывать в строке поиска
  ' маску со след. символами: ?-любой символ, *-любая последовательность символов, #-любая цифра.
  ' возвращает позицию начала/конца совпадения маски со строкой, если не совпала, то возвращает - 0
  ' [start]       - с какой позиции в string1 начать сравнение с маской - string2
  ' [string1]     - строка в которой ищут последов. символов совпадающей с маской - string2
  ' [string2]     - маска, которую сравнивают со строкой string1. Маска может содержать спец. символы сравнения:
  '                 ?-любой символ, *-любая последовательность символов(но не меньше одного), #-любая цифра.
  ' [compare]     - 0-бинарное сравнение, 1-текстовое сравнение (различие описано ниже, в тексте программы)
  '                 описание типов сравнение с примерами дано ниже, в комментариях к коду
  ' [begORendPos] - функция возвратит позицию начала совпадения маски с исходной строкой (True)
  '                 или позицию конца совпадения маски (False). В случае если последний символ
  '                 маски - "*", то тогда при begORendPos=False функция вернет
  '                 позицию последнего символа string1, т.е. Len(string1)
 
  Dim i As Integer, k As Integer, sa As String, mb As String
  Dim bFind As Boolean
  Dim iSymbI As Integer
  Dim iSymbK As Integer
 
  On Error GoTo ОбработчикОшибок
 
  ' когда первая позиция для сравнения указана неправильно возвр. Null
  If start < 1 Then Err.Raise vbObjectError + 513
 
  i = start      ' с какой позиции начать сравнение в string1
  k = 0          ' счетчик совпавших уже символов в маске
  iSymbK = 0     ' при каком k в маске находится "*"
  iSymbI = 0     ' при каком i в маске находится "*"
  InStrMask = 0  ' на какой позиции совпала маска
 
  Do While Len(string1) > i - 1 And Len(string2) > k
 
    bFind = False
 
    sa = Mid(string1, i, 1)     ' символ из строки в которой сравнивают
    mb = Mid(string2, k + 1, 1) ' символ из строки-маски
       
    Select Case mb
      Case "?" ' любой символ
        bFind = True
       
      Case "*" ' любая последовательность символов
        iSymbK = k
        iSymbI = i + 1
        bFind = True
       
      Case "#" ' любая цифра
        If Asc(sa) > 47 And Asc(sa) < 58 Then
           bFind = True
        Else
           bFind = False
        End If
       
      Case Else ' все остальные символы
        If compare = 0 Then
            ' сравнение бинарное, т.е. "p"<>"P", а только "p"="p"
            If Asc(mb) = Asc(sa) Then
                bFind = True
            Else
                bFind = False
            End If
        Else
            ' сравнение текстовое, т.е. "p"="P" и "p"="p"
            If LCase(mb) = LCase(sa) Then
                bFind = True
            Else
                bFind = False
            End If
        End If
    End Select
       
    ' проверка необх. возврата к предыд. символам маски
    If Not bFind And iSymbK > 0 Then
      k = iSymbK
      i = iSymbI
      bFind = True
    End If
   
    ' подготовка к след. сравнению
    If bFind Then
        k = k + 1
        If begORendPos Then
          ' возвращаем начало совпадения маски со string1
          If InStrMask = 0 Then InStrMask = i
        Else
          ' возвращаем конец совпадения маски со string1
          InStrMask = i
        End If
    Else
        k = 0
        InStrMask = 0
    End If
   
    i = i + 1
  Loop
 
  ' Итоговая проверка:
  ' закончил крутить цикл потому что перебрал все символы в string1 или
  ' потому что вся маска совпала. Для это проверяем дошла k до конца маски string2
  If Len(string2) = k Then
     ' если последний символ совпавшей маски "*", то возвращаем
     ' Len(string1)
     If Right(string2, 1) = "*" And begORendPos = False Then _
        InStrMask = Len(string1)
  Else
     InStrMask = 0
  End If
     
 
Exit_Fun:
  Exit Function
 
ОбработчикОшибок:
   InStrMask = ""
   Resume Exit_Fun
 
End Function

Public Function StrUCase(Str As String, CountSymbol As Integer) As String
' Возвращает первые заглавные символы из строки, если они идут подряд и их кол-во - CountSymbol
' иначе - пустую строку

  Dim iCount As Integer
 
  iCount = 0
  StrUCase = ""
  For i = 1 To Len(Str)
    If (Asc(Mid(Str, i, 1)) > 64 And Asc(Mid(Str, i, 1)) < 91) Or _
       (Asc(Mid(Str, i, 1)) > 191 And Asc(Mid(Str, i, 1)) < 224) Or _
       (Asc(Mid(Str, i, 1)) > 47 And Asc(Mid(Str, i, 1)) < 58) Then
       iCount = iCount + 1
    Else
       iCount = 0
    End If
    If iCount = CountSymbol Then
      StrUCase = Mid(Str, i - CountSymbol + 1, CountSymbol)
      Exit For
    End If
  Next i
   
End Function

Public Function CountStrUCase(Str As String, CountSymbol As Integer) As Integer
' Возвращает кол-во символов в строке, удовлет.: заглавные символы идут подряд и их кол-во - CountSymbol (+цифры),
' стоят отдельно от других заглавн. символов

  Dim iCount As Integer, LeftSide As Boolean, RightSide As Boolean, s As String
 
  iCount = 0
  CountStrUCase = 0
   
  For i = 1 To Len(Str)
    LeftSide = False
    RightSide = False
   
    If (Asc(Mid(Str, i, 1)) > 64 And Asc(Mid(Str, i, 1)) < 91) Or _
       (Asc(Mid(Str, i, 1)) > 191 And Asc(Mid(Str, i, 1)) < 224) Or _
       (Asc(Mid(Str, i, 1)) > 47 And Asc(Mid(Str, i, 1)) < 58) Then
           iCount = iCount + 1
    Else
           iCount = 0
    End If
    If iCount = CountSymbol Then
      If Val(Mid(Str, i - CountSymbol + 1, CountSymbol)) < 1000 Then _
        ' проверка на отдельн. стоящ.
        If (i - CountSymbol) > 0 Then  ' проверка слева
           s = Mid(str, i - CountSymbol, 1)
           If (Asc(s) > 64 And Asc(s) < 91) Or _
              (Asc(s) > 191 And Asc(s) < 224) Or _
              (Asc(s) > 47 And Asc(s) < 58) Then
                LeftSide = False
           Else
                LeftSide = True
           End If
        Else                    ' слева ничего нет
          LeftSide = True
        End If
        If i + 1 < Len(str) Then ' проверка справа
           s = Mid(str, i + 1, 1)
           If (Asc(s) > 64 And Asc(s) < 91) Or _
              (Asc(s) > 191 And Asc(s) < 224) Or _
              (Asc(s) > 47 And Asc(s) < 58) Then
                RightSide = False
           Else
                RightSide = True
           End If
        Else                    ' справа ничего нет
          RightSide = True
        End If
        If RightSide And LeftSide Then
          CountStrUCase = CountStrUCase + 1
        End If
      End If
    End If
  Next i
   
End Function

Public Function CountProbelDel(CurPos As Long, sstr As String) As Integer
' Возвращает количество пробелов с указанной позиции
Dim str As String
  str = Right(sstr, Len(sstr) - CurPos)
  CountProbelDel = Len(str) - Len(LTrim(str))
End Function

Public Function MyStr(sstr As String, BegLg As Long, SymbEnd As String) As String
' Вырезает строку с BegLg начала и до символа SymbEnd попутно избавлясь от пробелов на концах строки
Dim str As String, CountBadSymbol As Integer
Dim EndLg As Long
  MyStr = ""
  ' Отрезаем не нужную левую часть строки
  If BegLg < Len(sstr) Then ' Чтобы не было глюков
    str = Right(sstr, Len(sstr) - BegLg + 1)
    str = MyLTrim(str)
    ' Находим конец строки
    CountBadSymbol = 0
    Do
      EndLg = InStr(str, SymbEnd)
      If EndLg = 0 Then   ' Искомого символа нет, берем всю строку
        EndLg = Len(str) + 1
        CountBadSymbol = 0
      End If
      If EndLg = 1 Then   ' Для случая - запрос по Outlook. Вместо одного, там сразу несколько символов новой строки, хотя реально только один.
        str = Right(str, Len(str) - 1)
        CountBadSymbol = 1
      Else
        CountBadSymbol = 0
      End If
    Loop While CountBadSymbol = 1
    ' Вырезаем нужную часть строки
    str = Mid(str, 1, EndLg - 1)
    ' Убираем пробелы
    str = MyTrim(str)
    If Nz(str) <> "" Then MyStr = str
  End If

End Function

Public Function MyStrLen(sstr As String, BegLg As Long, MyLen As Long) As String
' Вырезает строку с BegLg начала и до конца MyLen попутно избавлясь от пробелов на концах строки
Dim str As String
Dim EndLg As Long
  MyStrLen = ""
  ' Отрезаем не нужную левую часть строки
  str = Right(sstr, Len(sstr) - BegLg + 1)
  str = MyLTrim(str)
  str = Mid(str, 1, MyLen)
  If Nz(str) <> "" Then MyStrLen = str

End Function

Public Function MyTrim(s As String) As String
' Освобождает оба конца строки от пробелов и спец. символов

Dim EndDo As Long
 
  MyTrim = s
  EndDo = 0 ' конец обработки
  s = Trim(s)
  Do
    Select Case Left(s, 1)
      Case Chr(10) ' вертикальная черта
        s = Right(s, Len(s) - 1)
        s = LTrim(s)
      Case Chr(13) ' перевод строки
        s = Right(s, Len(s) - 1)
        s = LTrim(s)
      Case Chr(58) ' ":"
        s = Right(s, Len(s) - 1)
        s = LTrim(s)
      Case Chr(45) ' "-"
        s = Right(s, Len(s) - 1)
        s = LTrim(s)
      Case Chr(95) ' "_"
        s = Right(s, Len(s) - 1)
        s = LTrim(s)
      Case Else
        EndDo = 1
    End Select
  Loop Until EndDo = 1
  ' А теперь тоже самое справа.
  EndDo = 0
  Do
    Select Case Right(s, 1)
      Case Chr(10) ' вертикальная черта
        s = Left(s, Len(s) - 1)
        s = RTrim(s)
      Case Chr(13) ' перевод строки
        s = Left(s, Len(s) - 1)
        s = RTrim(s)
      Case Chr(58) ' ":"
        s = Left(s, Len(s) - 1)
        s = RTrim(s)
      Case Chr(45) ' "-"
        s = Left(s, Len(s) - 1)
        s = RTrim(s)
      Case Chr(95) ' "_"
        s = Left(s, Len(s) - 1)
        s = RTrim(s)
      Case Else
        EndDo = 1
    End Select
  Loop Until EndDo = 1
  MyTrim = s
 
End Function

Public Function MyLTrim(s As String) As String
' Урезанный вариант MyTrim (только слева)
Dim EndDo As Long
 
  MyLTrim = s
  EndDo = 0 ' конец обработки
  s = Trim(s)
  Do
    Select Case Left(s, 1)
      Case Chr(10) ' вертикальная черта
        s = Right(s, Len(s) - 1)
        s = LTrim(s)
      Case Chr(13) ' перевод строки
        s = Right(s, Len(s) - 1)
        s = LTrim(s)
      Case Chr(58) ' ":"
        s = Right(s, Len(s) - 1)
        s = LTrim(s)
      Case Chr(45) ' "-"
        s = Right(s, Len(s) - 1)
        s = LTrim(s)
      Case Chr(95) ' "_"
        s = Right(s, Len(s) - 1)
        s = LTrim(s)
      Case Else
        EndDo = 1
    End Select
  Loop Until EndDo = 1
 
  MyLTrim = s
 
End Function

Public Function MyRTrim(s As String) As String
' Урезанный вариант MyTrim (только справа)
Dim EndDo As Long
 
  MyRTrim = s
  EndDo = 0 ' конец обработки
  s = Trim(s)
  Do
    Select Case Right(s, 1)
      Case Chr(10) ' вертикальная черта
        s = Left(s, Len(s) - 1)
        s = RTrim(s)
      Case Chr(13) ' перевод строки
        s = Left(s, Len(s) - 1)
        s = RTrim(s)
      Case Chr(58) ' ":"
        s = Left(s, Len(s) - 1)
        s = RTrim(s)
      Case Chr(45) ' "-"
        s = Left(s, Len(s) - 1)
        s = RTrim(s)
      Case Chr(95) ' "_"
        s = Left(s, Len(s) - 1)
        s = RTrim(s)
      Case Else
        EndDo = 1
    End Select
  Loop Until EndDo = 1
 
  MyRTrim = s
 
End Function

Public Function MyTrimMid(s As String) As String
' Избавляется от пробелов и спец символов с концов строки и от пробелов в внутри.
Dim i%, ss$
 
  ss = MyTrim(s)
  For i = 1 To Len(ss)
    If Mid(ss, i, 1) = " " Then
      ss = Left(ss, i - 1) & Right(ss, Len(ss) - i)
      i = i - 1
    End If
  Next i
  MyTrimMid = ss
 
End Function

Public Function FourDig(s As String) As String
' Вынимает 4 цифры из строки, если они идут в строке подряд в любом месте
  Dim i%, iCount%
 
  FourDig = s
  iCount% = 0
 
  For i = 1 To Len(s)
    If Asc(Mid(s, i, 1)) > 47 And Asc(Mid(s, i, 1)) < 58 Then
      iCount = iCount + 1
    Else
      iCount = 0
    End If
    ' Выход
    If iCount = 4 Then
      FourDig = Mid(s, i - 3, 4)
      Exit For
    End If
  Next i
 
End Function


Public Function IfNull(i As Long) As Long
' Если число ноль, то делает его равным 1
' для того, чтобы InStr не вылетал, когда ему  нулевую позицию дают
 
  If i <= 0 Then
    IfNull = 1
  Else
    IfNull = i
  End If
   
End Function

Public Function DelEnter(myString As String) As String
' Удаляет из строки спец. символы перевода каретки - Chr(10) и Chr(13)
' Использует функцию DelSymbolString
  Dim i As Integer
 
  DelEnter = DelSymbolString(myString, Chr(13))
  DelEnter = DelSymbolString(myString, Chr(10))
       
End Function

Public Function DelSymbolString(myString As String, sys As String) As String
' Удаляет из строки указанный символ - sys
  Dim i As Integer
 
  DelSymbolString = myString
  Do While InStr(1, myString, sys) > 0
    i = InStr(1, myString, sys)
    myString = Left(myString, i - 1) & Right(myString, Len(myString) - i)
  Loop
  DelSymbolString = myString
     
End Function


[Lexales]

Благодарю. Сейчас распечатаю и пойду разбираться.

[SergeySV2]

Благодарю. Сейчас распечатаю и пойду разбираться.

Да нет, функции только пример того, какие задачи по анализу строк могут стоять и как все они решаются встроенными InStr, Mid,...

Например если у тебя только ячейки со временем начинаются с цифр, то можно искать ячейки со временем анализируя только первый символ ячейки - усли цифра - то в ячейке время ...или послед. анализ ну и т.д.