Question

我有一个专栏＆＃34; F＆＃34;在workbook1中包含一些值（使用一些excel公式从其他列中提取和连接后获得）等等-RD1 等等，RD5 等等-RD6 blah-rd48do我想这样做等等-RD100 等

我有另一个专栏＆＃34; D＆＃34;在workbook2中包含像 RNDM，等等，rd1_sgjgs hjdf-等等，rd5_cnnv sdfhjdf-等等，rd100_cfdnnv ECT

基本上＆＃34; Blah-rdxx＆＃34;始终与workbook2的D列中的其他字符串一起出现

现在，我想做的是 - 如果workbook2的D列中的值包含workbook1的F列的值则在工作簿1（第5栏）的H栏中复制工作簿2的S列的对应值

这是我到目前为止已达到的地方，但它没有复制任何可能因为有一些问题并且外部循环没有迭代，我尝试了解决方案Nested For Next Loops: Outer loop not iterating并添加了n计数器但仍然外部循环没有＆＃39 ; t iterate -

Sub findandcopy()
Dim r As Range
Dim f As Range

Dim i As Long
Dim j As Long
Dim w1 As Worksheet
Dim w2 As Worksheet
Dim n As Integer

Set w1 = Workbooks("Book1.xlsm").Worksheets("sheet1")
Set w2 = Workbooks("Book2.xlsx").Worksheets("sheet1")


n = 0
For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To w1.Cells(Rows.Count, 1).End(xlUp).Row + n

If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then

w2.Cells(i, 2).Copy (w2.Cells(j, 5))
Exit For
n = n + 1
End If

Next j
Next i

End Sub

Answer 1

试试这个

Option Explicit

Public Sub FindAndCopy()

    Const F = "F"
    Const D = "D"
    Const H = 2
    Const S = 15

    Dim ws1 As Worksheet:   Set ws1 = Workbooks("Book1.xlsm").Worksheets("Sheet1")
    Dim ws2 As Worksheet:   Set ws2 = Workbooks("Book2.xlsm").Worksheets("Sheet1")
    Dim lr1 As Long:        lr1 = ws1.Cells(ws1.Rows.Count, F).End(xlUp).Row
    Dim lr2 As Long:        lr2 = ws2.Cells(ws2.Rows.Count, D).End(xlUp).Row

    Dim itm1 As Range, itm2 As Range

    Application.ScreenUpdating = False
    For Each itm2 In ws2.Range(ws2.Cells(1, D), ws2.Cells(lr2, D))      'Book2
        For Each itm1 In ws1.Range(ws1.Cells(1, F), ws1.Cells(lr1, F))  'Book1
            If Not IsError(itm1) And Not IsError(itm2) Then
                If InStr(1, itm2.Value2, itm1.Value2) > 0 Then
                    itm1.Offset(, H).Formula = itm2.Offset(, S).Formula 'Book1.H = Book2.S
                    Exit For
                End If
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub

原始代码，解释功能问题：

Sub findandcopy()
 Dim w1 As Worksheet, w2 As Worksheet
 Dim i As Long, j As Long, n As Integer

 Set w1 = Workbooks("Book1.xlsm").Worksheets("sheet1")
 Set w2 = Workbooks("Book2.xlsx").Worksheets("sheet1")

 n = 0
 For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row       'for each used cell in w2.colA
   For j = 1 To w1.Cells(Rows.Count, 1).End(xlUp).Row + n 'for each used cell in w1.colA

    'Find the text from w1.colC (current w1 row), within cell in w2.colA (current w2 row)
     If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then

      'If found then copy cell in w2.colB into cell in w2.colE (current w2 row)
       w2.Cells(i, 2).Copy (w2.Cells(i, 5))

       Exit For    'this exits the inner For loop

       n = n + 1   'this would jump over the next cell(s) in w1, but never executes
     End If
   Next j
 Next i
End Sub

缺少的缩进使得很难关注
有未使用的变量（r，f），w1 / w2名称可以表示工作簿或工作表
＆＃34; Option Explicit＆＃34;应该在每个模块的顶部使用
代码不处理有错误的单元格
- #N/A, #VALUE!, #REF!, #DIV/0!, #NUM!, #NAME?, or #NULL!

如果您想要对代码进行更详细的审核，一旦修复后您就可以将其发布到Code Review

vba在另一个工作簿的列中搜索单元格值

1 个答案: