VBA - печать пустых ячеек

Question

У меня есть код, который принимает информацию от под заголовком двух конкретных заголовков столбцов в открываемых файлах и печатает их в мастер-файле.

Один столбец пуст каждые несколько файлов, и мне нужно его для печати пустых ячеек в столбце 2 моего мастер-файла в диапазоне заполненных ячеек столбца 3. Петля находит последнюю использованную строку при печати на листе, поэтому даже если они пусты, они будут печатать над ними. Я предполагаю, что это то, что мне нужно будет исправить. Кроме того, если есть несколько занятых ячеек, за которыми следуют многие пустые ячейки, необходимо распечатать оба этих файла в мастер-файле.

Объяснение кода:

Мой код выводит информацию на мой MasterFILE в колонке 3, а затем столбец 2, то столбец 1 на основе количества ячеек в колонке 3. Там могут быть пустые ячейки в столбце 2, но не должно быть никаких пустых ячеек, которые встречаются в столбце 3; столбцы 2 и 3 всегда должны быть одинаковой длины (включая пробелы)

фраза «пустой держатель» печатает на колонке 2, если нет никаких значений вообще в держателе (но это только печатает, что когда-то и я нужно, чтобы он печатал его для того, сколько ячеек, эквивалентных столбцу 3, пуст. Я изменю эту фразу только на «», но слова просто помогут мне увидеть, что делает программа.

Фраза «НЕТ ДЕРЖАТЕЛЕЙ» PRESENT! "Распечатывается, когда нет файла заголовка HOLDER, найденного в любом месте листа.

Любые идеи, как я могу это исправить?

В настоящее время она выглядит (1), и мне нужно, чтобы выглядеть (2)

(1)

(2)

'(3) 
       'find CUTTING TOOL on the source sheet' 
       If Not ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
       Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) 
        Set dict = GetValues(hc.Offset(1, 0), "SplitMe") 
        If dict.count > 0 Then 
        'add the values to the master list, column 3 
         Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) 
         d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) 
        Else 
         'if no items are under the CUTTING TOOL header 
         StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = " empty TOOL " 
        End If 
       Else 
        StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO CUTTING TOOLS PRESENT" 
       End If 
'(4) 
       'find HOLDER on the source sheet 
       If Not ws.Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
       Set hc3 = ws.Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) 
        Set dict = GetValues(hc3.Offset(1, 0)) 
        If dict.count > 0 Then 
         'add the values to the master list, column 2 
         Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) 
         d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) 
        Else 
         'if no items are under the HOLDER header 
         StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = " empty HOLDER " 
        End If 
       Else 
        'if no HOLDER is found on the sheet 
        StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = "NO HOLDERS PRESENT!" 
       End If 

ПОЛНЫЙ КОД, ЕСЛИ НУЖНО

Option Explicit 

Sub LoopThroughDirectory() 

    Const ROW_HEADER As Long = 10 

    Dim objFSO As Object 
    Dim objFolder As Object 
    Dim objFile As Object 
    Dim dict As Object 
    Dim MyFolder As String 
    Dim f As String 
    Dim StartSht As Worksheet, ws As Worksheet 
    Dim WB As Workbook 
    Dim i As Integer 
    Dim LastRow As Integer, erow As Integer 
    Dim Height As Integer 
    Dim FinalRow As Long 
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, d As Range 
    Dim TDS As Range 
    Dim hc12 As Range, n As Range 

    Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1") 

    'turn screen updating off - makes program faster 
    Application.ScreenUpdating = False 

    'location of the folder in which the desired TDS files are 
    MyFolder = "C:\Users\trembos\Documents\TDS\progress\" 

    'find the headers on the sheet 
    Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER") 
    Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL") 
    Set hc4 = HeaderCell(StartSht.Range("A1"), "TOOLING DATA SHEET (TDS):") 

    'create an instance of the FileSystemObject 
    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    'get the folder object 
    Set objFolder = objFSO.GetFolder(MyFolder) 
    i = 2 

    'loop through directory file and print names 
'(1) 
    For Each objFile In objFolder.Files 
     If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then 
'(2) 
      'Open folder and file name, do not update links 
      Set WB = Workbooks.Open(FileName:=MyFolder & objFile.Name, UpdateLinks:=0) 
      Set ws = WB.ActiveSheet 

      With WB 
       For Each ws In .Worksheets 
'(3) 
       'find CUTTING TOOL on the source sheet' 
       If Not ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
       Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) 
        Set dict = GetValues(hc.Offset(1, 0), "SplitMe") 
        If dict.count > 0 Then 
        'add the values to the master list, column 3 
         Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) 
         d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) 
        Else 
         'if no items are under the CUTTING TOOL header 
         StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = " empty TOOL " 
        End If 
       Else 
        StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO CUTTING TOOLS PRESENT" 
       End If 
'(4) 
       'find HOLDER on the source sheet 
       If Not ws.Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
       Set hc3 = ws.Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) 
        Set dict = GetValues(hc3.Offset(1, 0)) 
        If dict.count > 0 Then 
         'add the values to the master list, column 2 
         Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) 
         d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) 
        Else 
         'if no items are under the HOLDER header 
         StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = " empty HOLDER " 
        End If 
       Else 
        'if no HOLDER is found on the sheet 
        StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = "NO HOLDERS PRESENT!" 
       End If 
'(5) 
       'print the file name to Column 4 
       StartSht.Cells(i, 4) = objFile.Name 

       With ws 
       'Print TDS name by searching for header 
        If Not ws.Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
         Set TDS = ws.Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1) 
         StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = TDS 
        Else 
         'print the file name wihtout the extension 
         StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = GetFilenameWithoutExtension(objFile.Name) 
        End If 
        i = GetLastRowInSheet(StartSht) + 1 
       End With 

       Next ws 
'(6) 
       'close, do not save any changes to the opened files 
       .Close SaveChanges:=False 
      End With 
     End If 
'(7) 
    'move to next file 
    Next objFile 
    'turn screen updating back on 
    Application.ScreenUpdating = True 
    ActiveWindow.ScrollRow = 1 'brings the viewer to the top of the masterfile 
End Sub 
'(8) 
'get all unique column values starting at cell c 
Function GetValues(ch As Range, Optional vSplit As Variant) As Scripting.Dictionary 

    Dim dict As Scripting.Dictionary 
    Dim dataRange As Range 
    Dim cell As Range 
    Dim theValue As String 
    Dim splitValues As Variant 

    Set dict = New Scripting.Dictionary 
    Set dataRange = ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells 
    ' If there are no values in this column then return an empty dictionary 
    ' If there are no values in this column, the dataRange will start at the row 
    ' *above* ch and end at ch 
    If (dataRange.Row = (ch.Row - 1)) And (dataRange.Rows.count = 2) And (Trim(ch.Value) = "") Then 
     GoTo Exit_Function 
    End If 

    For Each cell In dataRange.Cells 
     theValue = Trim(cell.Value) 
     If Len(theValue) = 0 Then 
      theValue = "none" 
     End If 
      'exclude any info after ";" 
      If Not IsMissing(vSplit) Then 
       splitValues = Split(theValue, ";") 
       theValue = splitValues(0) 
      End If 
      'exclude any info after "," 
      If Not IsMissing(vSplit) Then 
       splitValues = Split(theValue, ",") 
       theValue = splitValues(0) 
      End If 

      If Not dict.exists(theValue) Then 
      dict.Add theValue, theValue 
     End If 
    Next cell 
Exit_Function: 
    Set GetValues = dict 
End Function 
'(9) 
'find a header on a row: returns Nothing if not found 
Function HeaderCell(rng As Range, sHeader As String) As Range 
    Dim rv As Range, c As Range 
    For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells 
     'copy cell value if it contains some string "holder" or "cutting tool" 
     If Trim(c.Value) = sHeader Then 
     'If InStr(c.Value, sHeader) <> 0 Then 
      Set rv = c 
      Exit For 
     End If 
    Next c 
    Set HeaderCell = rv 
End Function 
'(10) 
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String) 
    With theWorksheet 
     GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row 
    End With 
End Function 
'(11) 
Function GetLastRowInSheet(theWorksheet As Worksheet) 
Dim ret 
    With theWorksheet 
     If Application.WorksheetFunction.CountA(.Cells) <> 0 Then 
      ret = .Cells.Find(What:="*", _ 
          After:=.Range("A1"), _ 
          LookAt:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
     Else 
      ret = 1 
     End If 
    End With 
    GetLastRowInSheet = ret 
End Function 
'(12) 
'get the file name without the extension 
Function GetFilenameWithoutExtension(ByVal FileName) 
    Dim Result, i 
    Result = FileName 
    i = InStrRev(FileName, ".") 
    If (i > 0) Then 
    Result = Mid(FileName, 1, i - 1) 
    End If 
    GetFilenameWithoutExtension = Result 
End Function 

Answer 1

Fix: Если бы распечатать пустой "" вниз в диапазоне, равном любой занят в колонке 3.

раздел, что фиксированный код:

(4) 
... 
     Else 
      'if no items are under the HOLDER header 
      StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = " "