Excel 复选框和数组
Excel Checkboxes and Arrays
我正在为与我合作的团队创建项目跟踪器,我想将单个项目的所有项目信息复制到一行中。然后行中的 2 列将是 "Task Complete" 和 "Date Completed".
目前我在任务完成单元格中使用数据验证列表 select "Complete"。当列出 "Complete" 时,完成日期将自动填充为 "Today's" 日期。我通过 excel 中的简单函数实现了这一点。
然后我创建了 VBA 代码,以便单击命令按钮时,它会突出显示行中的特定单元格,复制这些单元格,将它们粘贴到空白作品中sheet,然后清除任务和日期完成单元格。
我已经使用了这些功能中的大部分功能,但是我遇到了障碍,因为 excel 仅在空行中复制空白工作 sheet 中的数据(A1、A2 行、A3 等)。我不确定如何让代码复制空行中的数据。我知道它可以通过使用变量 (i) 和循环来实现。
我的另一个问题是,我最初想使用复选框而不是经过验证的列表,但似乎在使用复选框格式化时遇到了问题。如果我的行大小必须更改以适合文本,复选框将挤满其他单元格。这只是 excel 中 forms/activeX 的缺陷,还是我错过了大局的一部分?
我尝试使用数组来检查 "Task Complete" 列,而不是使用单独的 If 语句来添加日期。附件是我的代码示例:
Dim pjt As Worksheet
Dim datawks As Worksheet
Dim myBook As Workbook 'define worksheets and workboook
Set myBook = Excel.ActiveWorkbook
Set pjt = myBook.Sheets("Project Tracker")
Set datawks = myBook.Sheets("DATA")
Dim tskarray(16) As String
tskarray(0) = Range("K4")
tskarray(1) = Range("k5")
tskarray(2) = Range("k6")
tskarray(3) = Range("k7")
tskarray(4) = Range("k8")
tskarray(5) = Range("k9")
tskarray(6) = Range("k10")
tskarray(7) = Range("k11")
tskarray(8) = Range("k12")
tskarray(9) = Range("k13")
tskarray(10) = Range("k14")
tskarray(11) = Range("k15")
tskarray(12) = Range("k16")
tskarray(13) = Range("k17")
tskarray(14) = Range("k18")
tskarray(15) = Range("k19")
tskarray(16) = Range("k20")
If tskarray(0) = "Complete" Then
Range("A4,B4,D4,F4,G4,J4,L4").Select
Selection.Copy
datawks.Select
datawks.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, skipblanks _
:=False, Transpose:=False
Sheets("Project Tracker").Select
Application.CutCopyMode = False
pjt.Range("J4,K4").Select
Selection.ClearContents
Else
Debug.Print ("No Task to Complete")
End If
我相信这将完成您的任务(至少根据您的问题)合并您提到的循环。
Dim tskarray() As String
ReDim tskarray(0 To 16)
Dim ArrayElementCount As Long
Dim RowCount As Long
RowCount = 3 'this will increment by 1 at the start of the loop so after the last iteration it will end at 16 not 17
For ArrayElementCount = 0 To UBound(tskarray)
RowCount = RowCount + 1
tskarray(ArrayElementCount) = pjt.Range("K" & RowCount) 'Assuming on pjt sheet.
Next ArrayElementCount
Dim TargetCell As Range
Dim LastRow As Long
RowCount = 3
For ArrayElementCount = 0 To UBound(tskarray)
RowCount = RowCount + 1
If tskarray(ArrayElementCount) = "Complete" Then
For Each TargetCell In pjt.Range("A" & RowCount & ": L" & RowCount) 'Also assuming on pjt sheet
If TargetCell.Column = 3 Or TargetCell.Column = 5 Or TargetCell.Column = 8 Or TargetCell.Column = 9 Or TargetCell.Column = 11 Then
'Ignore columns C, E, H, I and K
Else
With datawks
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(LastRow, 1).Value = TargetCell.Value
End With
End If
Next TargetCell
pjt.Range("J" & RowCount & ":K" & RowCount).ClearContents 'Change the column letters if the range should be bigger.
Else
Debug.Print ("No Task to Complete")
End If
Next ArrayElementCount
因此,在这个线程上每个人的帮助下,尤其是@Samuel Everson 和家里的一些朋友,我能够让我的代码按预期工作。我想 post 工作代码以获得改进建议或其他可能具有类似 issues.The 代码的工作代码如下:
Dim LastRow As Long
Dim LastCol As Long
Dim i As Integer
Dim j As Range
RowCount = 3
ColCount = 3
i = 1
Set j = Range("a1").End(xlDown)
For ArrayCount = LBound(tskarray) To UBound(tskarray)
RowCount = RowCount + 1
ColCount = ColCount + 1
If tskarray(ArrayCount) = "Complete" Then
Do While i < 7
For Each TargetCell In pjt.Range("A" & RowCount & ": L" & RowCount)
If TargetCell.Column = 3 Or TargetCell.Column = 5 Or TargetCell.Column = 8 Or TargetCell.Column = 9 Or TargetCell.Column = 11 Then
Else
With datawks
.Range("A1").End(xlUp).Offset(j, i) = TargetCell.Value
i = i + 1
End With
End If
Next TargetCell
j = j + 1
Loop
i = 1
'pjt.Range("J" & RowCount & ":K" & RowCount).ClearContents
End If
Next ArrayCount
我正在为与我合作的团队创建项目跟踪器,我想将单个项目的所有项目信息复制到一行中。然后行中的 2 列将是 "Task Complete" 和 "Date Completed".
目前我在任务完成单元格中使用数据验证列表 select "Complete"。当列出 "Complete" 时,完成日期将自动填充为 "Today's" 日期。我通过 excel 中的简单函数实现了这一点。
然后我创建了 VBA 代码,以便单击命令按钮时,它会突出显示行中的特定单元格,复制这些单元格,将它们粘贴到空白作品中sheet,然后清除任务和日期完成单元格。
我已经使用了这些功能中的大部分功能,但是我遇到了障碍,因为 excel 仅在空行中复制空白工作 sheet 中的数据(A1、A2 行、A3 等)。我不确定如何让代码复制空行中的数据。我知道它可以通过使用变量 (i) 和循环来实现。
我的另一个问题是,我最初想使用复选框而不是经过验证的列表,但似乎在使用复选框格式化时遇到了问题。如果我的行大小必须更改以适合文本,复选框将挤满其他单元格。这只是 excel 中 forms/activeX 的缺陷,还是我错过了大局的一部分?
我尝试使用数组来检查 "Task Complete" 列,而不是使用单独的 If 语句来添加日期。附件是我的代码示例:
Dim pjt As Worksheet
Dim datawks As Worksheet
Dim myBook As Workbook 'define worksheets and workboook
Set myBook = Excel.ActiveWorkbook
Set pjt = myBook.Sheets("Project Tracker")
Set datawks = myBook.Sheets("DATA")
Dim tskarray(16) As String
tskarray(0) = Range("K4")
tskarray(1) = Range("k5")
tskarray(2) = Range("k6")
tskarray(3) = Range("k7")
tskarray(4) = Range("k8")
tskarray(5) = Range("k9")
tskarray(6) = Range("k10")
tskarray(7) = Range("k11")
tskarray(8) = Range("k12")
tskarray(9) = Range("k13")
tskarray(10) = Range("k14")
tskarray(11) = Range("k15")
tskarray(12) = Range("k16")
tskarray(13) = Range("k17")
tskarray(14) = Range("k18")
tskarray(15) = Range("k19")
tskarray(16) = Range("k20")
If tskarray(0) = "Complete" Then
Range("A4,B4,D4,F4,G4,J4,L4").Select
Selection.Copy
datawks.Select
datawks.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, skipblanks _
:=False, Transpose:=False
Sheets("Project Tracker").Select
Application.CutCopyMode = False
pjt.Range("J4,K4").Select
Selection.ClearContents
Else
Debug.Print ("No Task to Complete")
End If
我相信这将完成您的任务(至少根据您的问题)合并您提到的循环。
Dim tskarray() As String
ReDim tskarray(0 To 16)
Dim ArrayElementCount As Long
Dim RowCount As Long
RowCount = 3 'this will increment by 1 at the start of the loop so after the last iteration it will end at 16 not 17
For ArrayElementCount = 0 To UBound(tskarray)
RowCount = RowCount + 1
tskarray(ArrayElementCount) = pjt.Range("K" & RowCount) 'Assuming on pjt sheet.
Next ArrayElementCount
Dim TargetCell As Range
Dim LastRow As Long
RowCount = 3
For ArrayElementCount = 0 To UBound(tskarray)
RowCount = RowCount + 1
If tskarray(ArrayElementCount) = "Complete" Then
For Each TargetCell In pjt.Range("A" & RowCount & ": L" & RowCount) 'Also assuming on pjt sheet
If TargetCell.Column = 3 Or TargetCell.Column = 5 Or TargetCell.Column = 8 Or TargetCell.Column = 9 Or TargetCell.Column = 11 Then
'Ignore columns C, E, H, I and K
Else
With datawks
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(LastRow, 1).Value = TargetCell.Value
End With
End If
Next TargetCell
pjt.Range("J" & RowCount & ":K" & RowCount).ClearContents 'Change the column letters if the range should be bigger.
Else
Debug.Print ("No Task to Complete")
End If
Next ArrayElementCount
因此,在这个线程上每个人的帮助下,尤其是@Samuel Everson 和家里的一些朋友,我能够让我的代码按预期工作。我想 post 工作代码以获得改进建议或其他可能具有类似 issues.The 代码的工作代码如下:
Dim LastRow As Long
Dim LastCol As Long
Dim i As Integer
Dim j As Range
RowCount = 3
ColCount = 3
i = 1
Set j = Range("a1").End(xlDown)
For ArrayCount = LBound(tskarray) To UBound(tskarray)
RowCount = RowCount + 1
ColCount = ColCount + 1
If tskarray(ArrayCount) = "Complete" Then
Do While i < 7
For Each TargetCell In pjt.Range("A" & RowCount & ": L" & RowCount)
If TargetCell.Column = 3 Or TargetCell.Column = 5 Or TargetCell.Column = 8 Or TargetCell.Column = 9 Or TargetCell.Column = 11 Then
Else
With datawks
.Range("A1").End(xlUp).Offset(j, i) = TargetCell.Value
i = i + 1
End With
End If
Next TargetCell
j = j + 1
Loop
i = 1
'pjt.Range("J" & RowCount & ":K" & RowCount).ClearContents
End If
Next ArrayCount