Добрый день. Нашел на просторах интернета данный макрос. Реализован он в 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
Искал что то похожее в Екселе никто этим не занимался вроде, только в этом же источнике кто то выложил нечто подобное видимо, но сайт не рабочий у них да и старая тема.. до автора той ссылки вряд ли докопаться можно.
Fsociety_ написал: Подскажите как правильно все переписать, что бы работал абсолютно идентично и без лишних багов.
Для этого нужно знать ЧТО делает данный макрос, приложить файл-пример (Excel) Как есть - Как надо. Возможно будет проще написать НОВЫЙ макрос, чем разбираться в хитросплетениях чужой логики и незнакомого языка программирования. Хотя, навскидку, все операторы знакомы и должны работать в Excel
Sanja написал: Для этого нужно знать ЧТО делает данный макрос
я поэтому и приложил источник, потому что автор подробно все расписал на своем сайте, что бы всем было проще чем читать мои пересказы) Ну тогда попробую в кратце описать все сюда.
Цитата
Sanja написал: все операторы знакомы и должны работать в Excel
да я это заметил, пробовал что то сделать, но в некоторых моментах выдает ошибки и они мне не знакомы, подумал лучше отдать это дел тем кто больше с этим знаком.
Fsociety_, результат, который показан на картинке после фразы "Пример результата видно на скриншоте ниже", можно получить простой формулой типа =ЕСЛИОШИБКА(ВПР(...);"") Как я понял из обсуждения, основная проблема - карта соответствий. Она у Вас есть?
Fsociety_ написал: лучше отдать это дел тем кто больше с этим знаком.
c этим больше знаком раздел работа. А лучше поискать тоже самое но для Excel и закрыть вопрос. Ну конечно может найтись желающий который будет тупа переводить строки ThisComponent.Sheets.getByName("Карта") - ThisWorkbook.WorkSheets.("Карта").
vikttur написал: Можно же не переводить с иероглифов, а написать сразу кириллицей.
Ну я так посмотрел синтаксис почти екселевский, думал может доработак много не потребует. Поэтому сюда и обратился, т.к с этим не знаком, может кто сталкивался с этим, и вместо написания с нуля нового кода, можно заменить пару строк да и все.
Цитата
Казанский написал: Как я понял из обсуждения, основная проблема - карта соответствий.
Пример скинул, как таковой проблемы с картой соответствий нету, т.к макрос выполняет все то что нужно мне.
Цитата
Sanja написал: ...основная проблема - карта соответствий. Она у Вас есть?
да нету никаких проблем с ключевыми словами и картами)) народ в обсуждении придумывает себе проблемы. Хотя пост тот довольно старый, возможно 5 лет назад это было проблемой.. не уверен.
Вроде и не много переписывать , но например в первой процедуре 6 строк из 17 меняются, во второй 10, 7 в третьей .. Как думаете - интересно этим заниматься?
БМВ написал: Вроде и не много переписывать , но например в первой процедуре 6 строк из 17 меняются, во второй 10, 7 в третьей .. Как думаете - интересно этим заниматься?
нет не интересно, но опять же повторюсь, т.к данный случай мне не знаком, показалось довольно близским к екселю кодом, решил что возможно* с этим можно что то сделать, дабы не переписывать заного.
Как можно принимать решения о том, что можно сделать, если о том что нужно сделать не знаешь и ещё называть этот процесс - думать? Предполагать, на основании какого-то опыта, да, но и только.
Андрей 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, Казанский, прав. Макрос изначально должен искать по первой части слова, а не брать из любой части слова совпадающую комбинацию букв, и почему то столбцы он расширяет в листе Ядро при появлении результата, и эти столбцы наоборот появляются, не так как в листе Карта (там где должен быть "транзакционник", там "тип" и т.д)
bigorq написал: Я логику не правил, просто "перевел"
Почему не правильно? В LibreOffce исходным кодом по представленному примеру - тоже самое находит, что описал Казанский. Так что это скорее огрехи алгоритма, чем проблемы перевода.
Точно? Украинский язык очень похож на русский... Дальше продолжать? Я об объектной модели вы подумали - что на самом деле куда важнее - Tesla Model S похожа на на другие спортивные автомобили, но вы же не станете утверждать, что её двигатель можно починить в любой автомастерской?
Цитата
Fsociety_ написал: И я предположить что синтаксис довольно похож
Если бы вы так сразу написали, то в теме было бы написаны посты только от bigorq и Казанский, как заинтересовавшихся темой участников форума.
Андрей VG написал: Цитата Fsociety_ написал:И я предположить что синтаксис довольно похожЕсли бы вы так сразу написали, то в теме было бы написаны посты только от bigorq и Казанский , как заинтересовавшихся темой участников форума.
в первых сообщениях так и было написано с самого начала.. по крайней мере так подразумевалось.. возможно вы не так восприняли.