VBA Копировать заголовок в строки - PullRequest
Новая
       16

VBA Копировать заголовок в строки

0 голосов
/ 07 января 2019

с новым годом. У меня тупик с приведенным ниже кодом VBA. Ценю, если кто-нибудь может помочь мне здесь. У меня есть код ниже, который удаляет пустые строки и ненужные элементы из листа, и код работает отлично. Тем не менее, у меня есть условие, где мне нужно скопировать заголовок (желтым цветом) в столбец А. Как в примере: Копировать ячейку B1 в A3, A4, A5 и Копировать ячейку B6 в A7, A8 и так далее. У меня не было никакого успеха с If blank. Какое условие я должен применить, чтобы выполнить это? enter image description here

Sub Delete_Blank_Rows()
Dim lRow As Long
Dim iCntr As Long
Dim wks As Worksheet
Dim LngLastRow As Long, lngLastCol As Long, lngIdx As Long, _
    lngColCounter As Long
Dim blnAllBlank As Boolean
Dim UserInputSheet As String
Set wks = Sheets("FNDWRR")
With wks
    'Now that our sheet is defined, we'll find the last row and last column
    LngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
                         SearchOrder:=xlByRows, _
                         SearchDirection:=xlPrevious).Row
lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
                         SearchOrder:=xlByColumns, _
                         SearchDirection:=xlPrevious).Column
'Since we need to delete rows, we start from the bottom and move up
For lngIdx = LngLastRow To 1 Step -1
    'Start by setting a flag to immediately stop checking
    'if a cell is NOT blank and initializing the column counter
    blnAllBlank = True
    lngColCounter = 2
    'Check cells from left to right while the flag is True
    'and the we are within the farthest-right column
    While blnAllBlank And lngColCounter <= lngLastCol
        'If the cell is NOT blank, trip the flag and exit the loop
        If .Cells(lngIdx, lngColCounter) <> "" Then
            blnAllBlank = False
        Else
            lngColCounter = lngColCounter + 1
        End If
    Wend
    'Delete the row if the blnBlank variable is True
    If blnAllBlank Then
        .Rows(lngIdx).Delete
    End If
Next lngIdx
End With
lRow = 45000
For iCntr = lRow To 1 Step -1
    If Cells(iCntr, 7).Value = "Functional Currency" Then
        Rows(iCntr).Delete
    End If
Next
  Range("b1").EntireColumn.Insert  
 End Sub

1 Ответ

0 голосов
/ 07 января 2019

Попробуйте это: 

Sub copyHeaders()
    Dim lastRow As Integer
    Dim holdName As String

    lastRow = ActiveSheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

    For r = 1 To lastRow
        If Cells(r, 1) = "Hold Name" Then
            holdName = Cells(r, 2).Value
            GoTo NextRow
        End If
        If IsEmpty(Cells(r, 1)) And Not IsNull(holdName) Then Cells(r, 1).Value = holdName
NextRow:
    Next r

End Sub
...