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行，則這將一直延伸到已使用範圍的底部。

編輯：您還必須確保你更新到函數的引用。您也可以將單行代碼移動到被調用的位置，並保存更多行。