VBA – 从独特的范围获取价值

Set hc5 = HeaderCell2(ws.Cells(ROW_HEADER, 1), "TOOLING DATA SHEET") If hc5 <> "" Then hc5.Offset(, 1) = StartSht.Cells(Rows.count, hc4.Column).End(xlUp).Offset(1, 0) Else StartSht.Cells(i, 1) = 1 ... 'find a header on a row: returns Nothing if not found Function HeaderCell2(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 "tooling data sheet" If InStr(c.Value, sHeader) <> 0 Then Set rv = c Exit For End If Next c Set HeaderCell2 = rv End Function 

我有这个作为我的代码。 我只是把else在那里，看看如果if语句工作，这是不是因为它打印出1.我不知道我有什么问题，但错误说对象variables或块variables未设置 。 它应该find包含单词“TOOLING DATA SHEET”的单元格，向右移动一个单元格，获取该信息并将其输出到我的StartSht，称为masterfile。 请帮忙吗？ 我被困了几个小时

这里是完整的代码，如果你需要它。 （丑评了我们试图修复它）

 Option Explicit Sub LoopThroughDirectory() Const ROW_HEADER As Long = 10 Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim MyFolder 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 f As String Dim dict As Object Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, hc5 As Range, d As Range Dim c 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") '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 '(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) End If Else 'header not found on source worksheet 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) End If 'End If Else 'header not found on source worksheet End If '(4.2) ' find TDS on the source sheet Set hc5 = HeaderCell2(ws.Cells(ROW_HEADER, 1), "TOOLING DATA SHEET") If hc5 <> "" Then hc5.Offset(, 1) = StartSht.Cells(Rows.count, hc4.Column).End(xlUp).Offset(1, 0) Else StartSht.Cells(i, 1) = 1 ' Set d = StartSht.Cells(Rows.count, hc4.Column).End(xlUp).Offset(1, 0) ' d.Value = Application.Transpose(hc5) ' 'StartSht.Cells(i, 1).Paste '' Set dict = GetValues(hc5.Offset(0, 1)) '' 'If InStr(ROW_HEADER, "HOLDER") <> "" Then '' If dict.count > 0 Then '' Set d = StartSht.Cells(Rows.count, hc4.Column).End(xlUp).Offset(1, 0) '' 'add the values to the master list, column 2 '' d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) ' End If End If 'Else ' 'header not found on source worksheet 'End If '(5) With WB 'print TDS information For Each ws In .Worksheets 'print the file name to Column 1 StartSht.Cells(i, 4) = objFile.Name 'StartSht.Range(StartSht.Cells(i, 4), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 4)) = objFile.Name ' ' Set hc5 = HeaderCell2(ws.Cells(ROW_HEADER, 1), "TOOLING DATA SHEET") 'StartSht.Cells(Rows.count, hc5.Column).End(xlUp).Offset(1, 0) = hc5 ' d.Offset(, 1) = StartSht.Cells(Rows.count, hc4.Column).End(xlUp).Offset(1, 0) ' 'print TDS name from J1 cell to Column 4 (****change because we want header not cell) With ws ' '.Range("J1").Copy StartSht.Cells(i, 4) .Range("J1").Copy StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) '' 'StartSht.Cells(i, 4).Value2 = GetTDSName(ws, 1) '' 'StartSht.Cells(i, 4).Paste End With i = GetLastRowInSheet(StartSht) + 1 ' Set hc5 = HeaderCell2(ws.Cells(ROW_HEADER, 1), "TOOLING DATA SHEET (TDS):") ' If Not hc5 Is Nothing Then ' ' ' Set d = StartSht.Cells(Rows.count, hc4.Column).End(xlUp).Offset(1, 0) ' 'add the values to the master list, column 2 ' d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) ' Else ' 'header not found on source worksheet ' End If 'move to next file 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 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 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 '(9.2) 'find a header on a row: returns Nothing if not found Function HeaderCell2(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 "tooling data sheet" If InStr(c.Value, sHeader) <> 0 Then Set rv = c Exit For End If Next c Set HeaderCell2 = 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 Function GetTDSName(theWorksheet As Worksheet) Dim ret With theWorksheet If Application.WorksheetFunction.CountA(.Cells) <> 0 Then ret = Range("J1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1).Row Else ret = 1 End If End With GetTDSName = ret End Function 

编辑：CURRENT CODE ATTEMPT 它的工作原理是find标题，并打印出右边的单元格。 但是如果没有find标题，它将不会跳过并打印“”

 With ws If Not Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1) 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)) = "" End If End With 

Answer 1

处理一个没有设置的范围意味着你正在处理的范围是没有什么，并经常需要在代码中带来on error resume next 。 考虑这种“被动”的方法，不会为了检查它是否存在而破坏某些东西。

  Dim p As Long With ws If CBool(Application.CountIf(.Rows(ROW_HEADER), "TOOLING DATA SHEET")) Then p = Application.Match("TOOLING DATA SHEET", .Rows(ROW_HEADER), 0) .Cells(1, p + 1) = StartSht.Cells(Rows.Count, hc4.Column).End(xlUp).Offset(1, 0) Else StartSht.Cells(i, 1) = 1 End If End With 

在尝试匹配不在那里的东西时也会抛出一个错误， 确保被动COUNTIF在那里首先保证不会抛出错误。