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.约翰·史密斯

现在这是我拥有的VBA：

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，该错误消失了，但所有粘贴均被覆盖（duh）。我不记得以前做过什么，但是我基本上没有所有的工作表激活，这导致了超出范围的错误。我可以通过激活工作表来解决此问题，但这会导致我的变量导致错误。

我陷入了那个循环。任何帮助表示赞赏。：）

编辑：根据评论和答案，问题不在于VBA本身的编写方式。我认为这与无法在if语句中调用变量j有关。我找不到其他方法或解决此问题的方法。

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

从一张纸复制单元格，然后将另一张粘贴到可变单元格

3 个答案: