Question

我有一个电子表格，其值从A5开始并运行到AI列，行中可以有任意数量的条目。

A行包含物品代码（例如000-0000）

我希望生成一些代码来完成以下两个操作：

如果列AI =是，则复制整行并粘贴到下面。每个副本都会在A列的代码中添加一个连续的字母表字母（例如000-0000a）

非常感谢任何帮助。我发现的所有内容都扩展到复制到另一张表格，我正在努力打破代码。

由于

编辑：

请参阅下面的当前代码我一直试图开始工作，直到复制行但无法粘贴它。

Sub NewItems(c As Range)


Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String

'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range

'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")


'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngNewItems = objWorksheet.Range("A5:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)

'Now loop through all the cells in the range
For Each rngCell In rngNewItems.Cells

objWorksheet.Select

If rngCell.Value <> "Yes" Then
    'select the entire row
    rngCell.EntireRow.Select

    'copy the selection
    Selection.Copy

    'Now identify and select the new sheet to paste into
    Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
    objNewSheet.Select

    'Looking at your initial question, I believe you are trying to find the next     available row
    Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)


    Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
    ActiveSheet.Paste
End If

Next rngCell

objWorksheet.Select
objWorksheet.Cells(1, 1).Select

'Can do some basic error handing here

'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngNewItems = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing

End Sub

Answer 1

因此，您的代码需要解决很多问题。其中许多我已经触及过。但要注意的主要事项是，您正在测试A列而不是列AI是否存在＆＃34;是＆＃34; - 所以可能没有匹配因此没有副本。

由于粘贴目标由连接确定以创建工作表名称，因此您应该进行测试以确保工作表存在。

为了测试我只是确保存在一张名为Sheet1a的表格，Sheet1单元格A5具有＆＃34; a＆＃34;在其中，有一个＆＃34;是＆＃34;在AI栏中。这可以改进，但足以让你前进。

此行循环列A：

Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)

而这一行是测试列AI：

 If rngCell.Offset(, 35).Value <> "Yes"

注意<>表示不等于=

所以也许你想要：

If rngCell.Offset(, 35).Value = "Yes"

考虑以下重写。

Option Explicit

Public Sub NewItems()  'c As Range) 'I have commented out parameter which isn't currently used.

    Dim rngBurnDown As Range ' not used but also not declared
    Dim objWorksheet As Worksheet
    Dim rngNewItems As Range
    Dim rngCell As Range
    Dim strPasteToSheet As String
    Dim objNewSheet As Worksheet
    Dim lastRowTargetSheet As Long

    Set objWorksheet = ThisWorkbook.Sheets("Sheet1")

    Dim lastRow As Long

    lastRow = objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row

    Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)

    Dim copiedRange As Range 'for union

    For Each rngCell In rngNewItems.Cells

        'Debug.Print rngCell.Address 'shows where looping

        If rngCell.Offset(, 35).Value = "Yes" Then

            Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)

             Dim nextTargetCell As Range

             lastRowTargetSheet = objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row
             Set nextTargetCell = objNewSheet.Range("A" & lastRowTargetSheet)

             rngCell.EntireRow.Copy nextTargetCell

             Set objNewSheet = Nothing 'clear inside loop as you are setting in loop
             lastRowTargetSheet = 0
             Set nextTargetCell = Nothing

        End If

    Next rngCell

    objWorksheet.Cells(1, 1).Select

End Sub

至于你的刻字：

网上有很多例子来生成这些。这是@harfang从here获得的一种方式：

Sub List_A_to_ZZZZ()
    Dim i As Long
    For i = 1 To 20 ' I have shortened this QHarr. Original end was 475254 ' ColXL("ZZZZ")
        Debug.Print Right("---" & XLcL(i), 4)
    Next i
End Sub



Function XLcL(ByVal N As Long) As String
    Do While N > 0
        XLcL = Chr(vbKeyA + (N - 1) Mod 26) & XLcL
        N = (N - 1) \ 26
    Loop
End Function

Function ColXL(ByVal abc As String) As Long
    abc = Trim(Replace(UCase(abc), "-", ""))
    Do While Len(abc)
        ColXL = ColXL * 26 + (Asc(abc) - vbKeyA + 1)
        abc = Mid(abc, 2)
    Loop
End Function

如果cell = value，则复制并粘贴下面的单元格并添加

1 个答案: