VBA - 如果细胞是空的，针对特定范围

Question

返回空单元格我有我的代码，这个函数获取值从一个特定范围内的多个文件（范围从一列了最后一个值到指定的头）并将它们打印到一个工作表，我的主文件。它为两列进行。

我的问题是有时我会在一列中有1个值，在另一列中有8个值。他们应该总是相等的长度，所以我需要第一列打印1值单元格，然后是7个空白单元格。

我觉得去了解这将是抢第一个列在一个打开的文件，并同时拥有这些列的打印到一个的长度，因为它永远是正确的长度的最佳方式。任何想法如何去设置这个？我一直在玩它，但无法实现它的工作。

以为可以“刀具NUM”列的值设置为n，并有一切打印到长度为n（表示为部分（3）和我的代码（4））。我只是不知道如何设置后者。

下面是代码，我有，打肚里节（3）

If Not Range("A1:A24").Find(What:="TOOL NUM", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
     Set n = ws.Cells(Rows.count, 1).End(xlUp) 

在此行之前吧，在我的主文件，一切都将被打印到区域，我把它打印下来到“C”列的长度，所以我希望这将是一个很好的基础，可以打印到打开文件中任何第1列的长度。希望有帮助。

StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = TDS 

全码：

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 

    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 




If Not Range("A1:A24").Find(What:="TOOL NUM", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
'(3) 
       'find CUTTING TOOL on the source sheet 
       Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL") 
       If Not hc Is Nothing Then 
        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 
         StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "" 
        End If 
       Else 
        StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO 'CUTTING TOOL' PRESENT!" 
       End If 
'(4) 
       'find HOLDER on the source sheet 
       Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER") 
       If Not hc3 Is Nothing Then 
        Set dict = GetValues(hc3.Offset(1, 0)) 
        'If InStr(ROW_HEADER, "HOLDER") <> "" Then 
        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 
         StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "" 
        End If 
       Else 
        StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO 'CUTTING TOOL' PRESENT!" 
       End If 
End If 
'(5) 
      With WB 
        'print the file name to Column 4 
        StartSht.Cells(i, 4) = objFile.Name 

        With ws 
        'Print TDS name by searching for header 
         If Not Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
          Set TDS = 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 
          StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = "NO TDS VALUE!" 
         End If 
         i = GetLastRowInSheet(StartSht) + 1 
        End With 
'(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 Object 
    Dim dict As Object 
    Dim rng As Range, c As Range 
    Dim v 
    Dim spl As Variant 

    Set dict = CreateObject("scripting.dictionary") 

    For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells 
     v = Trim(c.Value) 
     If Len(v) > 0 And Not dict.exists(v) Then 

      'exclude any info after ";" 
      If Not IsMissing(vSplit) Then 
      spl = Split(v, ";") 
      v = spl(0) 
      End If 

      'exclude any info after "," 
      If Not IsMissing(vSplit) Then 
      spl = Split(v, ",") 
      v = spl(0) 
      End If 

      dict.Add c.Address, v 
     End If 

     If Len(v) = 0 Then 
      v = "" 
     End If 

'  If Len(v) = "" Then 
'   v = "" 
'  End If 

    Next c 
    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 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 

编辑：图片上传澄清意见 问题此图片是打开的文件是什么样子，我从2列“持有人”抢夺和“切削工具”，这里标有编号和切削工具

Answer 1

尝试获取最后一行t他工作表使用的范围。更改

Function GetLastRowInColumn(theWorksheet As Worksheet, col As String) 
    With theWorksheet 
     GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row 
    End With 
End Function 

要

Function GetLastRowInSheet(theWorksheet As Worksheet) 
    GetLastRowInColumn = theWorksheet.UsedRange.Rows.count 
End Function 

我认为您的工作表只包含必要的数据和没有附加一堆细胞所需的范围之外。例如，如果所有内容都在A1:C10之内，并且您的值低于第10行，则这将一直延伸到已使用范围的底部。

编辑：您还必须确保你更新到函数的引用。您也可以将单行代码移动到被调用的位置，并保存更多行。