大佬教程收集整理的这篇文章主要介绍了粘贴值与下面的填充行一样多，大佬教程大佬觉得挺不错的，现在分享给大家，也给大家做个参考。
一个星期以来，我一直试图找到解决以下问题的方法，但找不到任何东西......
重点来了；我的工作簿中有三个不同的工作表；
worksheets("Board") worksheets("reference") worksheets("FinalBoard") 在 worksheets("Board") 中有多个列填充了不同标题的数据。我可以做一个代码，将每个数据粘贴到工作表（“FinalBoard”）中，只有当这些标题以值“Fruit”开头时。
=>worksheets("Board")
| A | B | C | D |
|---|---|---|---|
| 水果-1 | 水果 2 | 水果 3 | Vege-1 |
| x | x | x | 是 |
| x | x | x | 是 |
这是我的代码；
子测试()
Worksheets("FinalBoard").Activate
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 Col As String
'~~> SetTing sheets
Set wsinput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
With wsinput
'~~> Find last column in Row 2
lCol = .Cells(2,.columns.Count).End(xlToleft).column
'~~> Loop through columns
For i = 1 To lCol
'~~> check for my criterias
If .Cells(2,i).Value2 like "Fruit*" Then
'~~> Get column 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 all datas bellow each headers
.Range(Col & "3:" & Col & lRowinput).copy _
wsOutput.Range("B" & lRowOutput)
End If
Next i
结尾 结束子
然而，问题就在这里我想添加一个额外的条件。在此过程中，如果这些标题中的每一个都与包含在 worksheets("reference") 中的单词列表中的单元格匹配，则复制该单元格旁边的值（位于列“B”中）并将其粘贴到 worksheets("Final Board") 中列（“A”）。
=>worksheets("reference") ;
| A | B |
|---|---|
| 水果-1 | N01 |
| 水果 2 | N02 |
| 水果 3 | N03 |
| 水果 4 | N04 |
worksheets("FinalBoard") ;
|一个 |乙 |
| -------- | -------------- |
|代码 | X 值 |
| N01 | × |
| N02 | ×|
|N03|x|
只要我运行我的代码，什么都没有发生；没有消息，没有错误。 我还想在之前我向您展示的代码中插入以下代码以简化流程，并且不再运行此宏！
这是：
Dim wsTEST1,wsTEST2,wsTEST3 As Worksheet
Dim lCol As Long
Dim i,j,e As Long
Dim Col As String
Dim cell As Range
Dim lastlineRef,lastlinediStrib,lastlineResult As Long
'~~> Declaration
Set wsTEST1 = Sheets("Board")
Set wsTEST2 = Sheets("Reference")
Set wsTEST3 = Sheets("FinalBoard")
With wsTEST1
'~~> loop through columns ( declaration)
lCol = .Cells(2,.columns.Count).End(xlToleft).column
lastlineRef = Worksheets("Reference").Range("A" & rows.Count).End(xlUp).row
lastlineResult = Worksheets("FinalBoard").Range("A" & rows.Count).End(xlUp).row
'~~> loop through columns
For i = 1 To lCol 'unti last column
'~~> research criterias
If .Cells(2,i).Value like "Fruit*" Then
For e = 1 To lastlineResult
If wsTEST1.Cells(2,i).Value = Worksheets("Reference").Range("A" & i) Then
Worksheets("Reference").Range("A" & E).offset(,1).copy Worksheets("FinalBoard").Range("A" & E)
End If
Next e
End If
Next i
End With
end sub
我觉得我离找到正确的代码很近了……我再次非常感谢您的帮助！ :)
Sub test()
Dim wsInput As Worksheet,wsOutput As Worksheet,wsRef As Worksheet
Dim lRowInput As Long,lRowOutput As Long,iLastRef As Long
Dim lCol As Long,i As Long,n As Long,s As String
' Dictionary as look up table
Dim Dict As Object,key As String
Set Dict = CreateObject("ScripTing.Dictionary")
Set wsRef = Sheets("reference")
With wsRef
iLastRef = .Cells(Rows.Count,"A").End(xlUp).Row
For i = 1 To iLastRef
key = Trim(.Cells(i,"A"))
Dict(key) = .Cells(i,"B")
Next
End With
'~~> SetTing sheets
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
lRowOutput = 2
With wsInput
' Find last column in Row 2
lCol = .Cells(2,.columns.Count).End(xlToLeft).column
' Loop through columns
For i = 1 To lCol
'~~> check for my criterias
s = Trim(.Cells(2,i).Value2)
If s Like "Fruit*" Then
' Get the last row in that column
lRowInput = .Cells(.Rows.Count,i).End(xlUp).Row
n = lRowInput - 2 ' no of rows to copy
' Copy all datas bellow each headers
.Cells(3,i).Resize(n).Copy wsOutput.Range("B" & lRowOutput)
' add col A if match
if Dict.exists(s) Then
wsOutput.Range("A" & lRowOutput).Resize(n) = Dict(s)
End If
lRowOutput = lRowOutput + n
End If
Next i
End With
End Sub
以上是大佬教程为你收集整理的粘贴值与下面的填充行一样多全部内容，希望文章能够帮你解决粘贴值与下面的填充行一样多所遇到的程序开发问题。
如果觉得大佬教程网站内容还不错，欢迎将大佬教程推荐给程序员好友。
本图文内容来源于网友网络收集整理提供，作为学习参考使用，版权属于原作者。
如您有任何意见或建议可联系处理。小编QQ：384754419，请注明来意。