从一个工作表复制单元格并粘贴到另一个工作表中到可变单元格

Question

如果单元格包含特定值（弄清楚这部分），我会复制单元格（从 sheet1）。

我需要将它们粘贴到第 j 行的 sheet2 上的一个单元格中。

Sheet1 有一长串姓名、公司、电子邮件、电话等，每个人的信息用空格分隔。 例如：

Column A                       Column B
Smith, Jill                     #N/A
CEO                             #N/A
ABC Corp 123 street             ABC Corp
jill@ABC.com                    #N/A
                                #N/A
Smith, John                     #N/A
CTO                             #N/A
123 Inc ABC street              123 Inc
john@123.com                    #N/A

我有一个计算每个空格的变量 (j)，然后如果单元格 b 不等于#NA，则将单元格 a 复制并粘贴到 sheet2 列 M 和行 j 中。
需要变量 j，因为 B 列中的公式不是 100%，并且数据不一致，所以我需要 j，以便公司名称与名称保持在同一行。 我需要这个，因为我有其他代码将 A 列（如 4000 行）按姓名、职务、公司、电子邮件拆分为单独的工作表。

即 Sheet3 会有：
1. 吉尔·史密斯
2. 约翰·史密斯

Sub AutoCompany()
Application.ScreenUpdating = False
Dim lr As Long, tr As Long, i As Long, j As Long, k As Long

Worksheets("Sheet1").Activate

lr = Range("A" & Rows.Count).End(xlUp).Row

tr = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row - 1

'this is my formula for column B
Range("B2:B" & lr).Formula = "=INDEX(CompaniesTbl[CompanyNamesList],IF(SUMPRODUCT(--ISNUMBER(SEARCH(CompaniesTbl[CompanyNamesList],A2)))<>0,SUMPRODUCT(--ISNUMBER(SEARCH(CompaniesTbl[CompanyNamesList],A2))*ROW($1:$" & tr & ")),NA()))"
j = 0
k = 1

For i = 2 To lr Step 1
    'increase j by 1 if there is a blank space (to figure out where to paste)
    If Cells(i, 1) = "" Then
        j = j + 1
        'extra  variable just cause
        k = k + 1
    End If
    'check for an actual value
    If Application.IsNA(Cells(i, 2)) Then
        Else
        Worksheets("Sheet1").Cells(i, 2).Select
        Selection.Copy
        Worksheets("Company").Activate
        Worksheets("Company").Range("M" & j).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Worksheets("Sheet1").Activate
    End If
    Next

Application.ScreenUpdating = True
End Sub

这会导致错误

“对象定义或变量定义”

如果我从我的粘贴选择中删除 j，错误就消失了，但我所有的粘贴都被覆盖了。

我不记得我之前做了什么，但我基本上没有激活所有的工作表，这导致了超出范围的错误。 我通过激活工作表来修复它，但这会导致我的变量导致错误。

编辑：
根据评论和回答，问题不在于 VBA 本身是如何编写的。 我认为这与变量 j 无法在 if 语句中调用有关。 我想不出另一种方法来执行此操作或如何解决该问题。

Answer 1

通过破译您的代码，我假设您从第一行开始将公司名称从 B 列复制到Worksheets("Company") M 列。

Dim cel As Range, j As Long 'assign your variables

    With ThisWorkbook.Sheets("Sheet1") 'use "With" so you don't have to activate your worksheets
    j = 1
        For Each cel In .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row) 'loop through each cell in range
            If Application.IsNA(cel) Then 'test for error and skip

            ElseIf cel.Value = "" Then 'test for blank cell and skip

            'It is better to set a cells value equal to another cells value then using copy/paste.
            Else: ThisWorkbook.Sheets("Company").Cells(j, "M").Value = cel.Value

            j = j + 1 'add 1 to j to paste on the next row

            End If
        Next cel
    End With

Answer 2

检查我的代码的注释并根据您的需要进行调整

Option Explicit ' -> Always use this at the top of your modules and classes

' Define your procedures as public or private
' Indent your code (I use RubberDuck (http://rubberduckvba.com/) which is a great piece of software!
Public Sub AutoCompany()

    On Error GoTo CleanFail

    Application.ScreenUpdating = False           ' This should be used with an error handler see https://rubberduckvba.wordpress.com/tag/error-handling/

    ' Declare object variables
    Dim sourceSheet As Worksheet
    Dim lookupSheet As Worksheet
    Dim resultsSheet As Worksheet

    Dim sourceRange As Range
    Dim evalCell As Range

    ' Declare other variables
    Dim sourceSheetName As String
    Dim lookupSheetName As String
    Dim resultsSheetName As String
    Dim sourceLastRow As Long
    Dim lookupLastRow As Long

    ' Initialize variables
    sourceSheetName = "Sheet1"
    lookupSheetName = "Sheet2"
    resultsSheetName = "Company"

    ' Initialize objects
    Set sourceSheet = ThisWorkbook.Worksheets(sourceSheetName) ' This could be replaced by using the sheet's codename see https://www.spreadsheet1.com/vba-codenames.html
    Set lookupSheet = ThisWorkbook.Worksheets(lookupSheetName) ' Same as previous comment
    Set resultsSheet = ThisWorkbook.Worksheets(resultsSheetName) ' Same as previous comment

    ' Worksheets("Sheet1").Activate -> Not needed

    sourceLastRow = sourceSheet.Range("A" & Rows.Count).End(xlUp).Row ' This is unreliable -> see https://stackoverflow.com/a/49971492/1521579
    lookupLastRow = lookupSheet.Range("A" & Rows.Count).End(xlUp).Row - 1 ' Couldn't understand why you subtract 1

    ' Define the sourceRange so we can loop through the cells
    Set sourceRange = sourceSheet.Range("A2:A" & sourceLastRow)

    ' this is my formula for column B -> Comments should tell why you do something not what you're doing
    sourceSheet.Range("B2:B" & sourceLastRow).Formula = "=INDEX(CompaniesTbl[CompanyNamesList],IF(SUMPRODUCT(--ISNUMBER(SEARCH(CompaniesTbl[CompanyNamesList],A2)))<>0,SUMPRODUCT(--ISNUMBER(SEARCH(CompaniesTbl[CompanyNamesList],A2))*ROW($1:$" & lookupLastRow & ")),NA()))"


    ' Begin the loop to search for matching results
    For Each evalCell In sourceRange

        ' Skip cells that are empty
        If evalCell.Value <> vbNullString Then

            ' Check value in column B (offset = 1 refers to one column after current cell and using not before application.IsNA checks for is found)
            If Not Application.WorksheetFunction.IsNA(evalCell.Offset(rowOffset:=0, ColumnOffset:=1).Value) Then

                ' We use current evaluated cell row in the results sheet
                resultsSheet.Range("M" & evalCell.Row).Value = evalCell.Value

            End If

        End If

    Next evalCell

CleanExit:
    Application.ScreenUpdating = True
    Exit Sub

CleanFail:
    Debug.Print "Catched an err: " & Err.Description & " ... do something!"
    Resume CleanExit
End Sub

让我知道它是否有效，如果有效请记住标记答案

Answer 3

感谢所有尝试提供帮助的人。 我发现了问题。 我的 J 变量设置为 0，因此代码第一次运行时，它尝试粘贴到超出工作表范围的单元格 0。 我将变量设置为 0 的原因是因为我假设它找到的第一个空行（在数据集上方）会将变量设置为 1，但事实并非如此。 无论如何，我将 J 设置为 1 并且它起作用了...... D'oh