VBA 遮蔽交替行
VBA Shade Alternate Rows
使用 this site as a source, I've put together this 从给定文件夹中提取和列出文件的工作簿。
代码运行良好,但我试图通过对 C、D 和 E 列中的交替行添加阴影来稍微调整一下。
我对此进行了研究并找到了一个示例 here
我遇到的问题是我只能设法遮蔽列 E
,我不确定为什么。我也想用阴影遮住备用行,但我有点不确定该怎么做。
这是提取文件并对行添加阴影的代码。
Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
Dim lngLastRow As Long
On Error Resume Next
For Each FileItem In SourceFolder.Files
' display file properties
Cells(iRow, 3).Formula = iRow - 13
Cells(iRow, 4).Formula = FileItem.Name
Cells(iRow, 5).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
FileItem.Path, TextToDisplay:="Click Here to Open"
iRow = iRow + 1 ' next row number
lngLastRow = Sh.Cells(Cells.Rows.Count, "C").End(xlUp).Row
Range("C14:E" & lngLastRow).Activate
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=0"
Selection.FormatConditions(1).Interior.ColorIndex = 24
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
我只是想知道是否有人可以看看这个并让我知道哪里出了问题。
试一试,寻找 "add" 评论。另外请注意,我刚刚为另一个色带选择了另一种颜色 - 您可以根据需要进行更改。
Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, _
IncludeSubfolders As Boolean)
Dim lngLastRow As Long
Dim Toggle as integer 'added this here
On Error Resume Next
Toggle = 0
For Each FileItem In SourceFolder.Files
' display file properties
Cells(iRow, 3).Formula = iRow - 13
Cells(iRow, 4).Formula = FileItem.Name
Cells(iRow, 5).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
FileItem.Path, TextToDisplay:="Click Here to Open"
iRow = iRow + 1 ' next row number
lngLastRow = Sh.Cells(Cells.Rows.Count, "C").End(xlUp).Row
Range("C14:E" & lngLastRow).Activate
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, _
Formula1:="=MOD(ROW(),2)=0"
'-----------------------------------
'Add this section here
if toggle = 0 then
Selection.FormatConditions(1).Interior.ColorIndex = 24
toggle = 1
Else
Selection.FormatConditions(1).Interior.ColorIndex = 42
toggle = 0
end if
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
除非我遗漏了什么,否则您不需要单元格中的公式来创建 VBA 控制的替代阴影方案。在没有文件目录代码的情况下,我创建了一个快速例程来为 C、D 和 E 列的交替行添加阴影。
如果您可以从上面的例程中删除 FormatConditions 代码,这可能是一个可以接受的替代品。
Sub ReShade(startRow As Integer, endRow As Integer)
'--- begin by "erasing" the previous row coloring
ActiveSheet.Range(Cells(startRow, 3), Cells(endRow, 5)).Interior.ColorIndex = xlNone
'--- shades alternate rows in columnd C, D, E
Dim r As Integer
Dim rowCells As Range
For r = startRow To endRow Step 2
Set rowCells = ActiveSheet.Range(Cells(r, 3), Cells(r, 5))
With rowCells
.Interior.ColorIndex = 24
End With
Next r
End Sub
'--- call ReShade at the end of your routine, as in...
Sub test()
ReShade 5, 20
End Sub
对于那些感兴趣的人,这是我的工作代码:
Public Sub ListFilesInFolder(SourceFolder As Scripting.folder,IncludeSubfolders As Boolean)
Dim LastRow As Long
On Error Resume Next
For Each FileItem In SourceFolder.Files
' display file properties
Cells(iRow, 3).Formula = iRow - 12
Cells(iRow, 4).Formula = FileItem.Name
Cells(iRow, 5).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
FileItem.Path, TextToDisplay:="Click Here to Open"
iRow = iRow + 1 ' next row number
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
For Each Cell In Range("C13:E" & LastRow) ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
Cell.Interior.Color = RGB(232, 232, 232) ''color to preference
Else
Cell.Interior.Color = RGB(141, 180, 226) 'color to preference or remove
End If
Next Cell
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
使用 this site as a source, I've put together this 从给定文件夹中提取和列出文件的工作簿。
代码运行良好,但我试图通过对 C、D 和 E 列中的交替行添加阴影来稍微调整一下。
我对此进行了研究并找到了一个示例 here
我遇到的问题是我只能设法遮蔽列 E
,我不确定为什么。我也想用阴影遮住备用行,但我有点不确定该怎么做。
这是提取文件并对行添加阴影的代码。
Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
Dim lngLastRow As Long
On Error Resume Next
For Each FileItem In SourceFolder.Files
' display file properties
Cells(iRow, 3).Formula = iRow - 13
Cells(iRow, 4).Formula = FileItem.Name
Cells(iRow, 5).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
FileItem.Path, TextToDisplay:="Click Here to Open"
iRow = iRow + 1 ' next row number
lngLastRow = Sh.Cells(Cells.Rows.Count, "C").End(xlUp).Row
Range("C14:E" & lngLastRow).Activate
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=0"
Selection.FormatConditions(1).Interior.ColorIndex = 24
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
我只是想知道是否有人可以看看这个并让我知道哪里出了问题。
试一试,寻找 "add" 评论。另外请注意,我刚刚为另一个色带选择了另一种颜色 - 您可以根据需要进行更改。
Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, _
IncludeSubfolders As Boolean)
Dim lngLastRow As Long
Dim Toggle as integer 'added this here
On Error Resume Next
Toggle = 0
For Each FileItem In SourceFolder.Files
' display file properties
Cells(iRow, 3).Formula = iRow - 13
Cells(iRow, 4).Formula = FileItem.Name
Cells(iRow, 5).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
FileItem.Path, TextToDisplay:="Click Here to Open"
iRow = iRow + 1 ' next row number
lngLastRow = Sh.Cells(Cells.Rows.Count, "C").End(xlUp).Row
Range("C14:E" & lngLastRow).Activate
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, _
Formula1:="=MOD(ROW(),2)=0"
'-----------------------------------
'Add this section here
if toggle = 0 then
Selection.FormatConditions(1).Interior.ColorIndex = 24
toggle = 1
Else
Selection.FormatConditions(1).Interior.ColorIndex = 42
toggle = 0
end if
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
除非我遗漏了什么,否则您不需要单元格中的公式来创建 VBA 控制的替代阴影方案。在没有文件目录代码的情况下,我创建了一个快速例程来为 C、D 和 E 列的交替行添加阴影。
如果您可以从上面的例程中删除 FormatConditions 代码,这可能是一个可以接受的替代品。
Sub ReShade(startRow As Integer, endRow As Integer)
'--- begin by "erasing" the previous row coloring
ActiveSheet.Range(Cells(startRow, 3), Cells(endRow, 5)).Interior.ColorIndex = xlNone
'--- shades alternate rows in columnd C, D, E
Dim r As Integer
Dim rowCells As Range
For r = startRow To endRow Step 2
Set rowCells = ActiveSheet.Range(Cells(r, 3), Cells(r, 5))
With rowCells
.Interior.ColorIndex = 24
End With
Next r
End Sub
'--- call ReShade at the end of your routine, as in...
Sub test()
ReShade 5, 20
End Sub
对于那些感兴趣的人,这是我的工作代码:
Public Sub ListFilesInFolder(SourceFolder As Scripting.folder,IncludeSubfolders As Boolean)
Dim LastRow As Long
On Error Resume Next
For Each FileItem In SourceFolder.Files
' display file properties
Cells(iRow, 3).Formula = iRow - 12
Cells(iRow, 4).Formula = FileItem.Name
Cells(iRow, 5).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
FileItem.Path, TextToDisplay:="Click Here to Open"
iRow = iRow + 1 ' next row number
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
For Each Cell In Range("C13:E" & LastRow) ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
Cell.Interior.Color = RGB(232, 232, 232) ''color to preference
Else
Cell.Interior.Color = RGB(141, 180, 226) 'color to preference or remove
End If
Next Cell
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub