Question

我在我的代码中有这个函数，它从多个文件中的特定范围获取值（从列中的最后一个值到指定标题的范围）并将它们打印到一个工作表中，我的主文件。它为两列做到这一点。

我的问题有时我会在一列中有1个值而在另一列中有8个值。它们的长度应始终相等，因此我需要第一列打印1个值单元格，然后是7个空白单元格。

我认为最好的解决方法是抓取打开文件中的第一列，并将这两列打印到该列的长度，因为它始终是正确的长度。知道怎么设置这个吗？我一直在玩它，但无法让它发挥作用。

我以为我可以将“TOOL 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列“HOLDER”和“CUTTING TOOL”中抓取，这里标有数字和切割工具 enter image description here

Answer 1

尝试获取工作表中使用范围的最后一行。变化

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行，则会一直延伸到已使用范围的底部。

编辑：您还必须确保更新对该功能的引用。您也可以将单行代码移动到调用它的位置，并为自己节省几行。

VBA - 如果单元格为空，则返回特定范围的空单元格

1 个答案: