Есть ли способ редактировать текст ячейки в зависимости от близости к другим пустым ячейкам? - PullRequest
0 голосов
/ 08 июля 2020

У меня есть отчет Excel, который является продуктом другой финансовой программы. Я использую результаты этой программы для разработки еще одного подробного отчета с использованием индекса / сопоставления и других функций Excel. Однако у меня возникла проблема с форматированием, заданным программой. (Просмотр изображения прилагается)

В основном мне нужно, чтобы текст кода выделенный был скопирован поверх последующих кодов, пока не будут достигнуты пустые ячейки, затем повторить для следующего выделенный код. Это идет вниз по многим строкам, где выделенный код в верхней части блока должен заменять следующие коды, но останавливается после попадания в две пустые ячейки. Есть ли способ добиться этого без макроса, возможно, используя формулу смещения? Если необходимо использовать макрос, этого тоже будет достаточно. Финансовая программа не позволит мне изменить формат, но мне нужны эти уникальные идентификаторы для создания сводной таблицы. Спасибо!

введите описание изображения здесь

1 Ответ

0 голосов
/ 09 июля 2020

Это должно сработать, если между копируемыми кодами всегда есть 2 пустые строки. В противном случае потребуется немного больше работы.

Option Explicit

Sub CopyCodes()

   Dim lCurRow   As Long
   Dim lLastRow  As Long
   Dim zCopyCode As String
   
   lLastRow = ActiveSheet.Rows.Count
   lLastRow = Cells(lLastRow, 1).End(xlUp).Row() + 1
   
   zCopyCode = Cells(2, 1).Value
   Debug.Print zCopyCode
   lCurRow = 3
  
   Do
     
     If (Cells(lCurRow, 1) <> "" And _
         Cells(lCurRow, 2) <> "") Then
       Cells(lCurRow, 1) = zCopyCode
       lCurRow = lCurRow + 1
     Else
       If (Cells(lCurRow, 1) = "" And _
           Cells(lCurRow, 2) = "") Then
         lCurRow = lCurRow + 2  'Skip 2 blank rows to next code
         zCopyCode = Cells(lCurRow, 1).Value
         lCurRow = lCurRow + 1  'Move to first row to possibly copy over
       End If
       
     End If
    
   Loop Until lCurRow = lLastRow
   
End Sub  'CopyCodes

HTH

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...