Страницы: 1 2 След.
RSS
Пометка маркерами фраз по карте словоформ, переделка макроса из OpenOffice для Excel
 
Добрый день.
Нашел на просторах интернета данный макрос. Реализован он в OpenOffice.
Нужно его перенести в Excel. Подскажите как правильно все переписать, что бы работал абсолютно идентично и без лишних багов.

Принцип действия:
Два листа (Ядро,Карта). В листе Карта берутся словоформы из столбца А, С, Е и т.д (при добавление в 1 строку названия столбца, он становится активным для макроса, значит по нему тоже нужно осуществлять поиск в ключевых словах) Эти словоформы макрос ищет в листе Ядро в столбце А. После того как он находит соответствующую словоформу в ключевых словах, то он напротив ячейки где нашел словоформу подставляет маркер который прописан для этой словоформы в листе с Картой (Маркеры ставятся в соседних столбцах справа от словоформ в листе Карта - это столбцы B, D, F) - (к словоформе в столбце А, подставляется маркер из столбца B и т.д).
Результат в примере:
Код
Sub Categorize
   Dim Cursor As Object, Map As Object, Range As Object
   Dim NumColumns As long, Col As long, NumRows As long
   Dim Head As String
   
   Map = ThisComponent.Sheets.getByName("Карта")
   Cursor = Map.createCursor
   Cursor.gotoEndOfUsedArea(True)
   NumColumns = Cursor.Columns.Count
   
   For Col = 0 To NumColumns - 1 Step 2
      Head = Map.getCellByPosition(Col, 0).String
      If Head <> "" Then
         NumRows = LastRowWithData(Col) + 1
         ParseMap(Head, Col, NumRows)
      End If
   Next Col
   MsgBox "Готово! Теперь можно посетить https://devaka.ru/ :)"
End Sub

Sub ParseMap (ByVal Head as String, ByVal Col as long, ByVal NumMarks as long)
   Dim Names(1 To NumMarks) As String, Keys(1 To NumMarks) As String
   Dim Core As Object, Map As Object, Cell As Object, Source As Object, Cursor As Object
   Dim I, J, NumRows, CellIndex
   
   CellIndex = GetCellByName(Head)
   Core = ThisComponent.Sheets.getByName("Ядро")
   Map = ThisComponent.Sheets.getByName("Карта")
   
   For I = 1 To NumMarks
      Keys(I) = Map.getCellByPosition(Col, I-1).String
      Names(I) = Map.getCellByPosition(Col + 1, I-1).String
   Next I
   
   Cursor = Core.createCursor
   Cursor.gotoEndOfUsedArea(True)
   NumRows = Cursor.Rows.Count
      
   For I = 1 To NumRows
      Source = Core.getCellByPosition(0, I)
      Cell = Core.getCellByPosition(CellIndex, I)
      
      For J = 1 To NumMarks
         If InStr(LCase(Source.String), LCase(Keys(J))) > 0 Then
            Cell.String = Names(J)
         End If
      Next J
   Next I
End Sub

Function GetCellByName (Head as String)
   Dim Core As Object, Cursor As Object
   Dim J
   
   Core = ThisComponent.Sheets.getByName("Ядро")
   Cursor = Core.createCursor
   Cursor.gotoEndOfUsedArea(True)
   NumColumns = Cursor.Columns.Count
   
   For J = 1 To NumColumns
      If Core.getCellByPosition(J - 1, 0).String = Head Then
         GetCellByName = J - 1
         Exit Function
      End If
   Next
   
   Core.Columns.insertByIndex(1, 1)
   Core.getCellByPosition(1, 0).String = Head
   GetCellByName = 1
End Function

Function LastRowWithData (ColumnIndex as long) as long
   Dim Cursor As Object, Range As Object, Map As Object
   Dim LastRowOfUsedArea as long, R as long
   Dim RangeData

   Map = ThisComponent.Sheets.getByName("Карта")
   Cursor = Map.createCursor
   Cursor.gotoEndOfUsedArea(False)
   LastRowOfUsedArea = Cursor.RangeAddress.EndRow
   Range = Map.getCellRangeByPosition(ColumnIndex, 0, ColumnIndex, LastRowOfUsedArea)
   Cursor = Map.createCursorByRange(Range)
   RangeData = Cursor.getDataArray

   For R = UBound(RangeData) To LBound(RangeData) Step - 1
      If RangeData(R)(0) <> "" then
         LastRowWithData = R
         Exit Function
      End If
   Next
End Function

Вот источник автора кода, там он подробно описал принцип работы, есть описание, скриншоты и видео:
https://devaka.ru/articles/oo-categorize-macros

Искал что то похожее в Екселе никто этим не занимался вроде, только в этом же источнике кто то выложил нечто подобное видимо, но сайт не рабочий у них да и старая тема.. до автора той ссылки вряд ли докопаться можно.
Изменено: Fsociety_ - 17.04.2019 14:29:18
 
Цитата
Fsociety_ написал: Подскажите как правильно все переписать, что бы работал абсолютно идентично и без лишних багов.
Для этого нужно знать ЧТО делает данный макрос, приложить файл-пример (Excel) Как есть - Как надо. Возможно будет проще написать НОВЫЙ макрос, чем разбираться в хитросплетениях чужой логики и незнакомого языка программирования. Хотя, навскидку, все операторы знакомы и должны работать в Excel
Изменено: Sanja - 17.04.2019 11:24:36
Согласие есть продукт при полном непротивлении сторон
 
Ну и название для Темы ПРЕДЛОЖИТЬ соответствующее проблеме (той, которую решает нужный макрос)
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
Для этого нужно знать ЧТО делает данный макрос
я поэтому и приложил источник, потому что автор подробно все расписал на своем сайте, что бы всем было проще чем читать мои пересказы) Ну тогда попробую в кратце описать все сюда.
Цитата
Sanja написал:
все операторы знакомы и должны работать в Excel
да я это заметил, пробовал что то сделать, но в некоторых моментах выдает ошибки и они мне не знакомы, подумал лучше отдать это дел тем кто больше с этим знаком.
 
Fsociety_, результат, который показан на картинке после фразы "Пример результата видно на скриншоте ниже", можно получить простой формулой типа =ЕСЛИОШИБКА(ВПР(...);"")
Как я понял из обсуждения, основная проблема - карта соответствий. Она у Вас есть?
 
Цитата
Fsociety_ написал:
лучше отдать это дел тем кто больше с этим знаком.
c этим больше знаком раздел работа. А лучше поискать тоже самое но для Excel и закрыть вопрос. Ну конечно может найтись желающий который будет тупа переводить строки
ThisComponent.Sheets.getByName("Карта") -  ThisWorkbook.WorkSheets.("Карта").
По вопросам из тем форума, личку не читаю.
 
Пример. Заходите на русскоязычный форум и просите перевести китайский текст на русский. Китайцев нет. Много шансов получить перевод?

Название темы так и не предложено.
 
vikttur, Вить, китайский медведь конечно есть один, но он таким не занимается :-)
По вопросам из тем форума, личку не читаю.
 
Казанский, ВПР не подходит, нужен именно такой макрос. Пример приложил
 
Цитата
БМВ написал:
китайский медведь конечно есть
Панда? )
 
vikttur, Пометка маркерами фраз по карте словоформ
 
Цитата
Fsociety_ написал: по карте словоформ
Ключевые слова
Цитата
Казанский написал: Как я понял из обсуждения, основная проблема - карта соответствий. Она у Вас есть?
Согласие есть продукт при полном непротивлении сторон
 
Off
Цитата
Юрий М написал:
Панда? )

По вопросам из тем форума, личку не читаю.
 
Цитата
vikttur написал: Заходите на русскоязычный форум и просите перевести китайский текст на русский
Ну так и обратный вариант не очень :) Если зайдет на китайский форум и попросит перевести китайский текст на русский
 
А я агитировал за такое?
Название темы должно отражать суть задачи.  Можно же не переводить с иероглифов, а написать сразу кириллицей.
 
Цитата
vikttur написал: Можно же не переводить с иероглифов, а написать сразу кириллицей.
Ну я так посмотрел синтаксис почти екселевский, думал может доработак много не потребует. Поэтому сюда и обратился, т.к с этим не знаком, может кто сталкивался с этим, и вместо написания с нуля нового кода, можно заменить пару строк да и все.

Цитата
Казанский написал:
Как я понял из обсуждения, основная проблема - карта соответствий.
Пример скинул, как таковой проблемы с картой соответствий нету, т.к макрос выполняет все то что нужно мне.

Цитата
Sanja написал: ...основная проблема - карта соответствий. Она у Вас есть?
да нету никаких проблем с ключевыми словами и картами)) народ в обсуждении придумывает себе проблемы. Хотя пост тот довольно старый, возможно 5 лет назад это было проблемой.. не уверен.
 
Цитата
Fsociety_ написал:
почти екселевский
почти - не считается.

Вроде и не много переписывать , но например в первой процедуре 6 строк из 17 меняются, во второй 10, 7 в третьей ..  Как думаете  - интересно этим заниматься?
Изменено: БМВ - 17.04.2019 15:12:52
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
но например в первой процедуре 6 строк из 17 меняются, во второй 10, 7 в третьей ..
Эх, Михаил, вы не правы. С точки зрения менеджера всегда
Цитата
Fsociety_ написал:
можно заменить пару строк да и все.
:excl:
 
Андрей VG,  последнюю строку изобразить в форме собачки или кошечки и одну строку оставить прозрачной :-)
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
Вроде и не много переписывать , но например в первой процедуре 6 строк из 17 меняются, во второй 10, 7 в третьей ..  Как думаете  - интересно этим заниматься?
нет не интересно, но опять же повторюсь, т.к данный случай мне не знаком, показалось довольно близским к екселю кодом, решил что возможно* с этим можно что то сделать, дабы не переписывать заного.
 
Андрей VG, Вы бы прочли полностью предложение а не троллили отдельно взятые фразы)
 
Цитата
Fsociety_ написал:
а не троллили отдельно взятые фразы)
А подскажите, пожалуйста, как можно писать такое
Цитата
Fsociety_ написал:
думал может доработак много не потребует
Если
Цитата
Fsociety_ написал:
т.к с этим не знаком,
Как можно принимать решения о том, что можно сделать, если о том что нужно сделать не знаешь и ещё называть этот процесс - думать? Предполагать, на основании какого-то опыта, да, но и только.
 
Цитата
Андрей VG написал:
А подскажите, пожалуйста, как можно писать такое
легко можно такое писать, т.к предположение строиться на каких то выводах, выводом было наблюдение схожести синтаксиса языка для майкрософт офиса и эппл офиса. И я осмелился предположить что синтаксис довольно похож и возможно будет реальным минимальная доработка кода, вместо его полной перезаписи. Т.к я в этом небыл на сто процентов уверен, обратился на форум дабы узнать, возможно такое или нет, и если да то как такое можно сделать, если нет, то каким образом записать подобный функционал. Вместо какого то ответа вижу только оффтопные троли в свой адрес основанные на цеплянии к определенным фразам из целого контекста, что в принципе не логично. Если это весь удел данной темы, и конкретного ответа нету, то пожалуй тема закрыта.
 
Вольный перевод со словарем :)
Код
Sub Categorize()
   Dim Cursor As Object, Map As Object, Range As Object
   Dim NumColumns As Long, Col As Long, NumRows As Long
   Dim Head As String
   
   Set Map = ActiveWorkbook.Sheets("Карта")
    NumColumns = Map.Cells(2, Columns.Count).End(xlToLeft).Column
    
   For Col = 1 To NumColumns Step 2
      Head = Map.Cells(1, Col)
      If Head <> "" Then
         NumRows = Map.Cells(Rows.Count, Col).End(xlUp).Row
         Call ParseMap(Head, Col, NumRows)
       End If
   Next Col
   MsgBox "Здесь была реклама :)"
End Sub
 
Sub ParseMap(Head As String, Col As Long, NumMarks As Long)
   Dim Names() As String, Keys() As String
   
   Dim Core As Object, Map As Object, oCell, Source, Cursor As Object
   Dim I, J, NumRows, CellIndex
   
   ReDim Names(1 To NumMarks) As String
   ReDim Keys(1 To NumMarks) As String
   CellIndex = GetCellByName(Head)
    Set Core = ActiveWorkbook.Sheets("Ядро")
    Set Map = ActiveWorkbook.Sheets("Карта")
    
   For I = 1 To NumMarks
      Keys(I) = Map.Cells(I, Col)
      Names(I) = Map.Cells(I, Col + 1)
   Next I
    
   
   NumRows = Core.Cells(Rows.Count, 1).End(xlUp).Row
   
   For I = 1 To NumRows
        
       
      For J = 1 To NumMarks
         If InStr(LCase(Core.Cells(I, 1)), LCase(Keys(J))) > 0 Then
            Core.Cells(I, CellIndex) = Names(J)
         End If
      Next J
   Next I
End Sub
 
Function GetCellByName(Head As String)
   Dim Core As Object, Cursor As Object
   Dim J
    
    Set Core = ActiveWorkbook.Sheets("Ядро")
    NumColumns = Core.Cells(2, Columns.Count).End(xlToLeft).Column
   
    
   For J = 1 To NumColumns
      If Core.Cells(1, J) = Head Then
         GetCellByName = J
         Exit Function
      End If
   Next
   
   Core.Columns(2).Insert Shift:=xlToRight
   Core.Cells(1, 2) = Head
   GetCellByName = 2
End Function
 

Изменено: bigorq - 17.04.2019 16:31:28
 
bigorq, находит "транзакционник" цен в словах лицензия, лицензирование (строки 55, 84)
... как и формула
Код
=ЕСЛИОШИБКА(ПРОСМОТР(2;1/ПОИСК(Карта!$A$2:$A$4;A2);Карта!$B$2:$B$4);"")
;)
Изменено: Казанский - 17.04.2019 16:48:45
 
Казанский, так и в оригинале то же самое находит. Я логику не правил, просто "перевел" :)
 
bigorq, Казанский, прав. Макрос изначально должен искать по первой части слова, а не брать из любой части слова совпадающую комбинацию букв, и почему то столбцы он расширяет в листе Ядро при появлении результата, и эти столбцы наоборот появляются, не так как в листе Карта (там где должен быть "транзакционник", там "тип" и т.д)
Изменено: Fsociety_ - 17.04.2019 16:52:50
 
bigorq,в оригинале вроде ищет по первой части слова, точно не проверял, но по идее так должно было быть.

да в оригинале тоже так к сожалению. Возможным будет попросить Вас "доперевести" макрос до поиска по первой части слов?)
Изменено: Fsociety_ - 17.04.2019 16:59:23
 
Цитата
bigorq написал:
Я логику не правил, просто "перевел"
Почему не правильно? В LibreOffce исходным кодом по представленному примеру - тоже самое находит, что описал Казанский. Так что это скорее огрехи алгоритма, чем проблемы перевода.
Цитата
Fsociety_ написал:
эппл офиса.
Точно? Украинский язык очень похож на русский... Дальше продолжать? Я об объектной модели вы подумали - что на самом деле куда важнее - Tesla Model S похожа на на другие спортивные автомобили, но вы же не станете утверждать, что её двигатель можно починить в любой автомастерской?
Цитата
Fsociety_ написал:
И я предположить что синтаксис довольно похож
Если бы вы так сразу написали, то в теме было бы написаны посты только от bigorq и Казанский, как заинтересовавшихся темой участников форума. ;)
 
Цитата
Андрей VG написал:
Цитата Fsociety_  написал:И я предположить что синтаксис довольно похожЕсли бы вы так сразу написали, то в теме было бы написаны посты только от  bigorq  и  Казанский , как заинтересовавшихся темой участников форума.
в первых сообщениях так и было написано с самого начала.. по крайней мере так подразумевалось.. возможно вы не так восприняли.
Изменено: Fsociety_ - 17.04.2019 17:03:25
Страницы: 1 2 След.
Наверх