Excel vba - 如何在范围变化时 copy/paste
Excel vba - How to copy/paste when range varies
得到一个 sheet 包含 7000 行。数据位于 A-C 列中。 A 列是团队,B 列是人员,C 列是城镇。第 1 行包含 headers。
单元格 A2 是第一个团队名称。单元格 B2:C23 是人员和城镇(没有空单元格)。但是,单元格 A3:A23 为空。队名只写在persons/towns的第一行。
第 24 行为空白。
A25中有一个新的队名。 B25:C38 是 persons/towns。 A26:A38为空
我想做的是 copy/paste 将 A2 中的团队名称缩减为 A3 中的空单元格:A23。然后将A25至A26中的队名同理:A38。依此类推,370 个团队的大约 7000 行。
但是每个团队使用的行数各不相同,那么 VBA 如何考虑到这一点?
唯一固定的信息是每个 team/person/town-section 之间有一个空行。
实际上我自己几年前就写了这样一个脚本,因为很多分析工具都像那样将信息导出到excel
Select 您要处理的范围,即 A1:A7000,以及 运行 脚本:
Sub fill2()
Dim cell As Object
For Each cell In Selection
If cell = "" Then cell = cell.OffSet(-1, 0)
Next cell
End Sub
如果您接受仅使用公式的方法,则可以将此公式添加到单元格 D2 并向下复制。
=IF(B2<>"",IF(A2="",D1,A2),"")
然后复制 D 列并将值粘贴到 A 列中。
我想到了一个考虑空行的快速解决方案:
Option Explicit
Sub completeTeams()
Dim i As Long
Const startDataRow = 2
Dim lastDataRow As Long
Dim lastTeamRow As Long
Dim lastTeamFound As String
Dim teamCellData As String
Dim isEmptyLine As Boolean
Rem getting the last row with data (so using column B or C)
lastDataRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
teamCellData = vbNullString
lastTeamFound = ActiveSheet.Cells(startDataRow, "A").Text
For i = startDataRow To lastDataRow
Rem trying to get the actual team name
teamCellData = ActiveSheet.Cells(i, "A").Text
Rem check to skip empty lines
isEmptyLine = Len(teamCellData) = 0 And Len(ActiveSheet.Cells(i, "B").Text) = 0
If isEmptyLine Then GoTo skipBlankLine
If Len(teamCellData) > 0 Then
lastTeamFound = teamCellData
End If
ActiveSheet.Cells(i, "A").Value = lastTeamFound
skipBlankLine:
Next
End Sub
得到一个 sheet 包含 7000 行。数据位于 A-C 列中。 A 列是团队,B 列是人员,C 列是城镇。第 1 行包含 headers。 单元格 A2 是第一个团队名称。单元格 B2:C23 是人员和城镇(没有空单元格)。但是,单元格 A3:A23 为空。队名只写在persons/towns的第一行。
第 24 行为空白。 A25中有一个新的队名。 B25:C38 是 persons/towns。 A26:A38为空
我想做的是 copy/paste 将 A2 中的团队名称缩减为 A3 中的空单元格:A23。然后将A25至A26中的队名同理:A38。依此类推,370 个团队的大约 7000 行。
但是每个团队使用的行数各不相同,那么 VBA 如何考虑到这一点? 唯一固定的信息是每个 team/person/town-section 之间有一个空行。
实际上我自己几年前就写了这样一个脚本,因为很多分析工具都像那样将信息导出到excel
Select 您要处理的范围,即 A1:A7000,以及 运行 脚本:
Sub fill2()
Dim cell As Object
For Each cell In Selection
If cell = "" Then cell = cell.OffSet(-1, 0)
Next cell
End Sub
如果您接受仅使用公式的方法,则可以将此公式添加到单元格 D2 并向下复制。
=IF(B2<>"",IF(A2="",D1,A2),"")
然后复制 D 列并将值粘贴到 A 列中。
我想到了一个考虑空行的快速解决方案:
Option Explicit
Sub completeTeams()
Dim i As Long
Const startDataRow = 2
Dim lastDataRow As Long
Dim lastTeamRow As Long
Dim lastTeamFound As String
Dim teamCellData As String
Dim isEmptyLine As Boolean
Rem getting the last row with data (so using column B or C)
lastDataRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
teamCellData = vbNullString
lastTeamFound = ActiveSheet.Cells(startDataRow, "A").Text
For i = startDataRow To lastDataRow
Rem trying to get the actual team name
teamCellData = ActiveSheet.Cells(i, "A").Text
Rem check to skip empty lines
isEmptyLine = Len(teamCellData) = 0 And Len(ActiveSheet.Cells(i, "B").Text) = 0
If isEmptyLine Then GoTo skipBlankLine
If Len(teamCellData) > 0 Then
lastTeamFound = teamCellData
End If
ActiveSheet.Cells(i, "A").Value = lastTeamFound
skipBlankLine:
Next
End Sub