VBA – 打印空单元格
我有代码从打开文件中的两个特定的列标题中获取信息，并将其打印到主文件。
一列是空的每几个文件，我需要它在列3的填充单元格范围内的空白单元格打印到我的主文件第2列。循环find最后一次使用的行打印到表，所以即使他们空的，它会打印在他们身上。 我假设这是我需要修复。 而且，如果有几个被占用的单元格后面跟着许多空单元格，则需要将这两个单元格打印到主文件中。
代码说明：
我的代码将信息打印到我的主文件到第3列，然后列2，然后第1列基于单元格数在第3列。在第2列可以有空白单元格，但不应该有任何空白单元格出现在列3; 第2列和第3列的长度应始终相同 （包括空格）
如果在持有者中没有任何值，那么“empty HOLDER”这个短语打印到第2列（但是它只打印一次，我需要打印它，因为等于第3列的许多单元格都是空的。只是“”，但这些话只是为了帮助我看看程序在做什么。
短语“无人存在！” 当在工作表中的任何位置找不到头文件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
修正：如果在第3列中占用的空间范围内打印出空白。
固定代码的部分：
(4) ... Else 'if no items are under the HOLDER header StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = " "