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

Question

I copy cells (from sheet1) if they contain a specific value (got this part figured out).

I need to paste them in a cell on sheet2 in row j.

Sheet1 has a long list of names, companies, emails, phones etc. with each person's information separated by a space. For Ex:

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

I have a variable (j) that counts each space and then if Cell b does not equal #NA, then cell a is copied and pasted into sheet2 column M and row j.
Variable j is needed because the formula in column B isn't 100% and the data is inconsistent so I need j so that the company name stays on the same line as the name. I need this because I have other code to split column A (like 4000 rows) into separate sheets by names, titles, companies, emails.

Ie Sheet3 would have:
1. Jill Smith
2. John Smith

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

This causes an error

"object defined or variable defined"

If I remove j from my paste selection, the error is gone but all my pastes are overwritten.

I can't remember what I had done before, but I basically didn't have all of the sheet activations and that caused a out of range error. Which I fix by activating a sheet, but that causes my variable to cause an error.

Edit:
Based on the comments and answer, the issue is not in how the VBA is written per se. I think it has to do with the fact that the variable j is unable to be called in the if statement. I can't figure another way to do this or how to troubleshoot that issue.

Answer 1

From deciphering your code I assume that you what to copy the company names from column B to Worksheets("Company") column M, starting on the first row.

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

Check my code's comments and adjust it to fit your needs

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

Let me know if it works and remember to mark the answer if it does

Answer 3

Thanks to everyone that tried helping. I found the problem. My J variable was set to 0 and so the first time the code ran, it tried pasting to cell 0 which is out of scope of the worksheet. The reason why I had set my variable to 0 was because I assumed the first empty row that it finds (above the dataset) would set the variable to 1 but that was not the case. Anyways, I set J to 1 and it worked... D'oh