Excel VBA范围。查找以识别所有单词；日期“；并存储其位置

我希望从这个社区得到一些帮助

我需要编写一个代码，在不同单元格的第一行中搜索单词“Date”。我希望它找到每个单元格并告诉我它的列位置，以便稍后我可以要求它使用短数据格式化这些列

非常感谢

路易斯

这是Gary的学生提供的解决所有问题的代码

子日期查找器（） 作为字符串的Dim msg 变暗rng作为范围，单元格作为范围 设置rng=Intersect（范围（“1:1”），ActiveSheet.UsedRange）

末端接头

考虑：

Sub DateFinder()
    Dim msg As String
    Dim rng As Range, cell As Range
    Set rng = Intersect(Range("1:1"), ActiveSheet.UsedRange)

    For Each cell In rng
        If InStr(cell.Value, "Date") > 0 Then
            msg = msg & vbCrLf & cell.Column
        End If
    Next cell
    MsgBox msg
End Sub

将格式应用于特定列 适当调整常量部分中的值

代码

Option Explicit

Sub ChangeFormat()

' Variables

    Const SheetName As String = "Sheet1"  ' Worksheet Name
    Const SearchRow As Long = 1           ' Search Row
    Const FirstColumn As Long = 1         ' First Column
    Const Criteria As String = "Date"     ' Criteria

    Dim ws As Worksheet         ' Worksheet
    Dim rng As Range            ' Last Cell in Row, Search Range,
                                ' Last Cell in Column, First Cell of
                                ' Formatting Range, Formatting Range
    Dim cel As Range            ' Current Cell
    Dim ColumnsArray() As Long  ' Columns Array
    Dim NumberOfRows As Long    ' Number of Rows (to be formatted)
    Dim i As Long               ' Columns Array Elements (Columns) Counter

' Program

    ' Define Worksheet.
    Set ws = ThisWorkbook.Worksheets(SheetName)

    ' Define Search Range.

    ' Find Last Cell in Row i.e. the right-most cell in Search Row
    ' containing data.
    Set rng = ws.Rows(SearchRow) _
      .Find(What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
    ' Define Search Range.
    Set rng = ws.Range(ws.Cells(SearchRow, FirstColumn), rng)

    ' Collect Columns.

    ' Loop through cells in Search Range.
    For Each cel In rng
        ' Check if value of Current Cell is equal to Criteria.
        If cel.Value = Criteria Then
            GoSub CollectColumns
        End If
    Next cel
    ' Check if no cells with Criteria have been found.
    If i = 0 Then GoTo NothingFound

    ' Define Formatting Range.

    ' Define Last Cell in Column i.e. the bottom-most cell
    ' in its column containing data.
    Set rng = ws.Columns(ColumnsArray(0)) _
      .Find(What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
    ' Calculate the number of rows to be formatted.
    NumberOfRows = rng.Row - SearchRow ' (not adding Search Row)
    ' Define first column of Formatting Range.
    Set rng = ws.Cells(SearchRow + 1, ColumnsArray(0)).Resize(NumberOfRows)
    ' 'Add' the rest of the columns of Formatting Range using 'Union'.
    For i = 1 To UBound(ColumnsArray)
        Set rng = Union(rng, ws.Cells(SearchRow + 1, ColumnsArray(i)) _
          .Resize(NumberOfRows))
    Next i

    ' Apply formatting to Formatting Range.
    With rng
        .NumberFormat = "m/d/yyyy"  ' depending on your locale maybe "d.m.yyyy"
        .Font.Bold = True
        .Interior.ColorIndex = 6
    End With

    ' Inform User.
    MsgBox "Formatting finished successfully.", vbInformation

GoTo exitProcedure

' Subroutines

CollectColumns:
    ReDim Preserve ColumnsArray(i)
    ColumnsArray(i) = cel.Column
    i = i + 1
Return

' Labels

NothingFound:
    MsgBox "There were no cells containing '" & Criteria & "' in row '" _
      & SearchRow & "'.", vbExclamation
    GoTo exitProcedure

exitProcedure:

End Sub

我学到的最重要的一课

---

似乎不能将

调整大小

用于任何类型的非连续范围，包括一列或一行的范围，但可以使用

偏移量

。（我的第一个计划是收集单元格，然后在该范围内应用

Offset

和

Resize

）

你能用你迄今为止尝试过的代码回答你的问题吗？嘿@BigBen！谢谢你看。我还没有编写任何程序。我甚至不知道从哪里开始，所以在深入研究之前我需要一些想法。不幸的是，这个网站针对的是关于现有代码的具体问题，而不是像这样更广泛的问题。对

Find

方法做些研究。嗨@Gary的学生，代码运行得很好。我只是更改了工作表，我想让它查找那些“日期”。让我告诉你，这个解决方案非常巧妙，完全是爱！我只是投了赞成票，希望对大家有用！我真的很感激，你是最好的。

Option Explicit

Sub ChangeFormat()

' Variables

    Const SheetName As String = "Sheet1"  ' Worksheet Name
    Const SearchRow As Long = 1           ' Search Row
    Const FirstColumn As Long = 1         ' First Column
    Const Criteria As String = "Date"     ' Criteria

    Dim ws As Worksheet         ' Worksheet
    Dim rng As Range            ' Last Cell in Row, Search Range,
                                ' Last Cell in Column, First Cell of
                                ' Formatting Range, Formatting Range
    Dim cel As Range            ' Current Cell
    Dim ColumnsArray() As Long  ' Columns Array
    Dim NumberOfRows As Long    ' Number of Rows (to be formatted)
    Dim i As Long               ' Columns Array Elements (Columns) Counter

' Program

    ' Define Worksheet.
    Set ws = ThisWorkbook.Worksheets(SheetName)

    ' Define Search Range.

    ' Find Last Cell in Row i.e. the right-most cell in Search Row
    ' containing data.
    Set rng = ws.Rows(SearchRow) _
      .Find(What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
    ' Define Search Range.
    Set rng = ws.Range(ws.Cells(SearchRow, FirstColumn), rng)

    ' Collect Columns.

    ' Loop through cells in Search Range.
    For Each cel In rng
        ' Check if value of Current Cell is equal to Criteria.
        If cel.Value = Criteria Then
            GoSub CollectColumns
        End If
    Next cel
    ' Check if no cells with Criteria have been found.
    If i = 0 Then GoTo NothingFound

    ' Define Formatting Range.

    ' Define Last Cell in Column i.e. the bottom-most cell
    ' in its column containing data.
    Set rng = ws.Columns(ColumnsArray(0)) _
      .Find(What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
    ' Calculate the number of rows to be formatted.
    NumberOfRows = rng.Row - SearchRow ' (not adding Search Row)
    ' Define first column of Formatting Range.
    Set rng = ws.Cells(SearchRow + 1, ColumnsArray(0)).Resize(NumberOfRows)
    ' 'Add' the rest of the columns of Formatting Range using 'Union'.
    For i = 1 To UBound(ColumnsArray)
        Set rng = Union(rng, ws.Cells(SearchRow + 1, ColumnsArray(i)) _
          .Resize(NumberOfRows))
    Next i

    ' Apply formatting to Formatting Range.
    With rng
        .NumberFormat = "m/d/yyyy"  ' depending on your locale maybe "d.m.yyyy"
        .Font.Bold = True
        .Interior.ColorIndex = 6
    End With

    ' Inform User.
    MsgBox "Formatting finished successfully.", vbInformation

GoTo exitProcedure

' Subroutines

CollectColumns:
    ReDim Preserve ColumnsArray(i)
    ColumnsArray(i) = cel.Column
    i = i + 1
Return

' Labels

NothingFound:
    MsgBox "There were no cells containing '" & Criteria & "' in row '" _
      & SearchRow & "'.", vbExclamation
    GoTo exitProcedure

exitProcedure:

End Sub