Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Работа функции внутри макроса, перевести Function в Sub
 
Добрый день!!

помогите пожалуйста, нужно объяснение.
есть функция код который :
Код
Function SpecTrim(ByVal SourceString As String, ByVal CharsSet As String) As String
    arr = Split(SourceString, ",")
    If UBound(arr) > 0 Then
        If arr(UBound(arr)) = arr(UBound(arr) - 1) Then arr(UBound(arr)) = ""
        Result = Join(arr)
    Else
        Result = arr(0)
    End If
    For i = 1 To Len(CharsSet)
        Result = Replace(Result, Mid(CharsSet, i, 1), "")
    Next i
    SpecTrim = Result
End Function
как сделать так, что бы она работала в макросе?
к примеру взять значение из ячейки, прогнать его через эту функцию, а результат вставить в другую ячейку  (так же где и как задать "не нужные символы"?)

файл с примером работы прилагается

Заранее спасибо!
Изменено: Exzem - 23 Фев 2017 18:51:22
 
Код
Sub ApplyFunction()
Dim rngSource As Range
Dim Cl As Range
    With Worksheets("Лист1")
        Set rngSource = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        For Each Cl In rngSource.Cells
            Cl.Offset(, 1) = SpecTrim(Cl.Value, .Range("C1"))    'ненужные символы в ячейке 'С1'
        Next
    End With
End Sub

Function SpecTrim(SourceString As String, CharsSet As String) As String
    arr = Split(SourceString, ",")
    If UBound(arr) > 0 Then
        If arr(UBound(arr)) = arr(UBound(arr) - 1) Then arr(UBound(arr)) = ""
        Result = Join(arr)
    Else
        Result = arr(0)
    End If
    For i = 1 To Len(CharsSet)
        Result = Replace(Result, Mid(CharsSet, i, 1), "")
    Next i
    SpecTrim = Result
End Function
Согласие есть продукт при полном непротивлении сторон.
 
Код
Sub ApplyFunction()
Dim rngSource As Range
Dim Cl As Range
    With Worksheets("Лист1")
        Set rngSource = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        For Each Cl In rngSource.Cells
            Cl.Offset(, 1) = SpecTrim(Cl.Value, "*/.() """)    'ненужные символы в самом макросе'
        Next
    End With
End Sub
Согласие есть продукт при полном непротивлении сторон.
 
Sanja, попробовал по вашему примеру записать информацию в макрос, подскажите пожалуйста что тут не так?
Код
ish(k, m, j) = SpecTrim(mwb1.Cells(i, j + 3), Range("aa1"))
 
Цитата
Exzem написал: что тут не так?
Не знаю :(. Нужно видеть исходные данные и весь макрос
Ну а если на вскидку, то не указан лист для ячейки Cells(i, j + 3). Судя по аббревиатуре mwb1 это какая-то книга, а у ячейки родитель это лист
Согласие есть продукт при полном непротивлении сторон.
 
Вот весь марос
Код
Sub pisec()
Dim ish(3, 15, 10) As String
Dim vig(3, 15, 10) As String

Set mwb = ActiveWorkbook
Set mwbl = mwb.Sheets("1")
Set mwb2 = mwb.Sheets("2")
k = 1
m = 1
ish(k, 0, 0) = mwbl.Cells(1, 1)
For i = 1 To mwbl.Cells(Rows.Count, 1).End(xlUp).Row

 If ish(k, 0, 0) = mwbl.Cells(i, 1) Then
 For j = 0 To 6
  ish(k, m, j) = SpecTrim(mwb1.Cells(i, j + 3), Range("aa1"))
  Next j
  m = m + 1
  GoTo a
ElseIf ish(k, 0, 0) <> mwbl.Cells(i, 1) Then
 k = k + 1
 m = 1
 ish(k, 0, 0) = mwbl.Cells(i, 1)
For j = 0 To 6
  ish(k, m, j) = SpecTrim(mwb1.Cells(i, j + 3), Range("aa1"))
  Next j

 End If
a:
  Next i
k = 1
m = 1
vig(k, 0, 0) = mwb2.Cells(1, 1)
  For i = 1 To mwb2.Cells(Rows.Count, 1).End(xlUp).Row

 If vig(k, 0, 0) = mwb2.Cells(i, 1) Then
 For j = 0 To 6
  vig(k, m, j) = SpecTrim(mwb2.Cells(i, j + 3), Range("aa1"))
  Next j
  m = m + 1
  GoTo b
ElseIf vig(k, 0, 0) <> mwb2.Cells(i, 1) Then
 k = k + 1
 m = 1
 vig(k, 0, 0) = mwb2.Cells(i, 1)
For j = 0 To 6
  vig(k, m, j) = SpecTrim(mwb2.Cells(i, j + 3), Range("aa1"))
  Next j

 End If
b:
  Next i

End Sub
Function SpecTrim(ByVal SourceString As String, ByVal CharsSet As String) As String
    arr = Split(SourceString, ",")
    If UBound(arr) > 0 Then
        If arr(UBound(arr)) = arr(UBound(arr) - 1) Then arr(UBound(arr)) = ""
        Result = Join(arr)
    Else
        Result = arr(0)
    End If
    For i = 1 To Len(CharsSet)
        Result = Replace(Result, Mid(CharsSet, i, 1), "")
    Next i
    SpecTrim = Result
End Function
Изменено: Exzem - 23 Фев 2017 20:58:14
 
А что Вы хотите этим макросом сделать и что не получается? Где ошибка возникает?
Согласие есть продукт при полном непротивлении сторон.
 
изначально макрос копировал инфу из определенных ячеек по определенным условиям в массив, но понадобилось, что бы он копировал туда информацию избавившись от всех лишних знаков ( заданных)
то есть брал в себя просто набор символов как в примере ( 1ый пост)
вот я и хотел спаять их в едино
 
Весь код не смотрел но
Set mwbl = mwb.Sheets("1")
а
mwb1.Cells(i, j+3)
буква l и цифра 1 разные вещи
Согласие есть продукт при полном непротивлении сторон.
 
Sanja, спасибо огромное, не знаю как подобная магия произошла, но сам бы я не заметил)
Страницы: 1
Читают тему (гостей: 1)