如何解决根据条件复制/粘贴单元格范围 x 次
我想用精确范围的数据填充板的每个空单元格。
我有两个工作表;
-worksheets("Board")
- worksheets("FinalBoard")
在工作表 worksheets("Board")
中,我有以下黑板;
类别 | Fruits-1 | Fruits-2 | Fruits-3 |
---|---|---|---|
A | 香蕉 | 樱桃 | 橙色 |
D | 苹果 | 芒果 | 草莓 |
B | 菠萝 | 西瓜 | 手榴弹 |
仅当标题以“Fruits”开头并将它们粘贴到工作表 worksheets("FinalBoard")
的一列中时,我才想选择每列数据。我可以使用名为 Fruits 的列执行此操作,并使用以下代码;
Sub P_Fruits()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim lRowInput As Long
Dim lRowOutput As Long
Dim lCol As Long
Dim i As Long
Dim n As Long
Dim s As String
Dim col As String
'~~> Sheets settings
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1,.Columns.Count).End(xlToLeft).Column
'~~> loop through columns
For i = 1 To lCol
'~~> research criterias
If .Cells(1,i).Value2 Like "Fruit-*" Then
'~~> Get columns name
col = Split(.Cells(,i).Address,"$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> copy-paste in the 2nd worksheet every data if the headers is found
.range(col & "2:" & col & lRowInput).copy _
wsOutput.range("B" & lRowOutput)
End If
Next i
end with
end sub
但是我想为“类别”列这样做并将类别的类型放在A列中每个水果的前面,从而多次重复复制的范围类别,尽可能多worksheets("Board")
中有以“Fruits”开头的标题。我试图在前一个代码中添加一个额外的代码,但没有用。这是我想要的结果;
类别粘贴 | 果酱 |
---|---|
A | 香蕉 |
D | 苹果 |
B | 菠萝 |
A | 樱桃 |
D | 甜瓜 |
B | 西瓜 |
A | 橙色 |
D | 草莓 |
B | 手榴弹 |
类别粘贴 | 果酱 |
---|---|
香蕉 | |
苹果 | |
菠萝 | |
樱桃 | |
甜瓜 | |
西瓜 | |
橙色 | |
草莓 | |
手榴弹 | |
A | |
D | |
B |
我的结局代码;
Sub Fruits_add()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim lRowInput As Long
Dim lRowOutput As Long
Dim lCol As Long
Dim i As Long
Dim n As Long
Dim s As String
Dim col As String
'~~> Sheets settings
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1,i).Value2 Like "Fruit-*" Then
'~~> Get column name
col = Split(.Cells(,"$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> copy-paste
.range(col & "2:" & col & lRowInput).copy _
wsOutput.range("B" & lRowOutput)
End If
Next i
'Code to repeat category type added
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1,.Columns.Count).End(xlToLeft).Column
'~~> loop through columns
For i = 1 To lCol
'~~> research criterias
If .Cells(1,i).Value2 Like "Category*" Then
'~~> Get column name
col = Split(.Cells(,"$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("A" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> copy-paste each category type in column A
.range(col & "2:" & col & lRowInput).copy _
wsOutput.range("A" & lRowOutput)
End If
Next i
End With
End With
我觉得我已经接近解决方案了。我很感激你们的帮助,谢谢!
解决方法
此代码将产生所需的结果,但使用不同的方法。
它做的第一件事是将源数据读入一个数组,然后遍历该数组并从标题以“Fruit”开头的每一列中提取水果/类别。
Option Explicit
Sub Fruits_add()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim arrDataIn As Variant
Dim arrDataOut As Variant
Dim idxCol As Long
Dim idxRow As Long
Dim cnt As Long
'~~> Sheets settings
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
' assumes data on 'Board' starts in A1
With wsInput
arrDataIn = .Range("A1").CurrentRegion.Value
End With
ReDim arrDataOut(1 To 2,1 To UBound(arrDataIn,1) * UBound(arrDataIn,2))
For idxCol = LBound(arrDataIn,2) To UBound(arrDataIn,2)
If arrDataIn(1,idxCol) Like "Fruits*" Then
For idxRow = LBound(arrDataIn,1) + 1 To UBound(arrDataIn,1)
cnt = cnt + 1
arrDataOut(1,cnt) = arrDataIn(idxRow,1)
arrDataOut(2,idxCol)
Next idxRow
End If
Next idxCol
If cnt > 0 Then
ReDim Preserve arrDataOut(1 To 2,1 To cnt)
End If
With wsOutput
.Range("A1:B1").Value = Array("Category-pasted","Fruit-pasted")
.Range("A2").Resize(cnt,2) = Application.Transpose(arrDataOut)
End With
End Sub
,
正如我在评论中所解释的,如果您已经找到正确的行,则不需要第二个循环 - 尽早获取类别列并稍后重用
你可以先在顶部添加这个变量声明
Dim col As String
然后继续执行第一个循环的代码(删除第二个循环
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1,.Columns.Count).End(xlToLeft).Column
'~~> loop through columns
For i = 1 To lCol
添加此项以首先检索类别
If .Cells(1,i).Value2 Like "Category*" Then
'~~> Get column name
colCat = Split(.Cells(,i).Address,"$")(1)
End If
'~~> research criterias
If .Cells(1,i).Value2 Like "Fruit-*" Then
'~~> Get column name
col = Split(.Cells(,"$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> Copy-paste
.range(col & "2:" & col & lRowInput).Copy _
wsOutput.range("B" & lRowOutput)
然后添加这个以粘贴类别
'~~> copy-paste each category type in column A
.range(colCat & "2:" & colCat & lRowInput).Copy _
wsOutput.range("A" & lRowOutput)
End If
Next i
End With
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。