Question

我有一个公司列表，每个公司都有工作范围，地址和电话号码。一些公司有多种工作范围。它看起来像这样：

SO20748873 question example

我希望在第二行中复制唯一数据并将其放在第一行然后摆脱它时，摆脱地址的第二个副本（以及我的情况下的电话号码等）第二行。

我对编码的经验很少。我一步一步查看了如何执行此操作，但代码或语法中出现了错误：

我找到了一个空白区域的代码。
我查看了如何将一个单元格复制到活动空白单元格的右侧。
我找到了将信息合并到活动单元格上方和右侧单元格中的代码。
我找到了删除活动单元格行的代码。
我希望它循环，直到没有空格company单元格。

所以这就是我把它放在一起的方式：

Public Sub SelectFirstBlankCell()
  Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
  Dim currentRowValue As String

  Do
    sourceCol = 6   'column F has a value of 6
    rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row

    'for every row, find the first blank cell and select it
    For currentRow = 1 To rowCount
      currentRowValue = Cells(currentRow, sourceCol).Value
      If IsEmpty(currentRowValue) Or currentRowValue = "" Then
      Cells(currentRow, sourceCol).Select
      End If
    Next
  Loop Until A647
End Sub

。

Sub mergeIt()
  Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(1, 1)).Merge
  ActiveCell.Select
End Sub

。

Sub DeleteRow()
  RowNo = ActiveCell.Row
  If RowNo < 7 Then Exit Sub
  Range("A" & ActiveCell.Row).EntireRow.Delete

  Sheets("Summary").Select
  Range("A4:O4").Select
  Selection.Copy
  LastRow = Range("A65536").End(xlUp).Offset(1, 0).Row
End Sub

Answer 1

请勿将代码作为图片发布，因为想要试用的人必须输入代码。您可以编辑您的问题，并在必要时添加包含修订代码的新部分。

我的代码副本（加上行号）是：

 1 Public Sub SelectFirstBlankCell()
 2   Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
 3   Dim currentRowValue As String

 4   sourceCol = 1   'column F has a value of 6
 5   rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row

 6   'for every row, find the first blank cell and select it
 7   For currentRow = 1 To rowCount
 8     currentRowValue = Cells(currentRow, sourceCol).Value
 9     If IsEmpty(currentRowValue) Or currentRowValue = "" Then
10       Cells(currentRow, sourceCol).Select
11     End If
12     Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(1, 1)).Merge
13     ActiveCell.Select
14     If IsEmpty(currentRowValue) Or currentRowValue = "" Then
15       Cells(Range("sourceCol:21")).Delete
16     End If
17     Next

18 End Sub

我确信我们都开始选择单元格并访问ActiveCell，因为宏录制器会这样做。但是，选择单元格很慢，很容易失去对所选内容的跟踪。我相信这是你的主要问题。

问题1 For-Loop的结束值在开始时是固定的;删除某些内容时，任何减少rowCount的尝试都不会对For-Loop产生任何影响。

问题2 我怀疑你的意思是第15行的范围是sourceCol & ":" & currentRow。

问题3 在第10行中，如果单元格为空，则选择该单元格。在第12行中，无论您是否刚刚选择它，都会合并活动单元格。这意味着您的代码会尝试每行合并。

问题4 第1列是可能为空的列。假设行1000是具有供应商名称的最后一行，但行1005是具有产品的最后一行。您的代码不会处理行1001到1005。

问题5 函数IsEmpty（）仅返回Variants的合理值。 Variant是一个可以包含不同类型值的单元格或变量。

我没有尝试过您的代码，因此可能会出现更多错误。得到沮丧。据我所知，问题1没有记录。我必须通过尝试类似于你的代码来为自己发现这个“功能”。 Function IsEmpty（）的规范说明了它的局限性，但除非你完全理解Variants，否则其意义并不明显。其他问题很容易出错，只有练习才能降低频率。

以下是我的问题解决方案。这不是我为自己编写代码的方式，但我认为我已经为一个解决方案引入了足够的新概念。

我没有多说我使用的VBA语句的语法，因为一旦你知道它存在就很容易查找语句。如有必要，请询问，但在询问之前请尝试理解代码。

我不喜欢原地删除;它很慢，如果您的代码有问题，您必须加载以前版本的工作表并重新开始。我有一个来源（Src）和一个目的地（Dest）工作表。

我将常量用于可能会更改的值，但不能在宏的单次运行期间使用。

您假设第2行和第3行的Jan's Supply的地址和其他详细信息匹配。我是偏执狂，从不做出这样的假设。如果我的代码在第2行和第3行不匹配时会丢弃重要信息，我会检查它们是否匹配。我也允许这样的行，因为我遇到过它们：

John's supply   Cookies           555 Main Street                CA
                Cakes                               Littleville  CA

这将成为：

John's supply   Cookies & Cakes   555 Main Street   Littleville  CA

有些评论解释了我对VBA陈述的选择，但大部分都没有。当你必须更新你在12个月前为新要求写的宏时，你花费几分钟时间来添加评论可以节省你在代码中找到方法的时间。

您可能不喜欢我的命名变量系统。精细;发展自己的。当您在12个月内返回此宏时，立即了解变量将节省更多时间。

Option Explicit

  Const WkshtSrcName As String = "Sheet1"    ' \ Replace "Sheet1" and "Sheet2"
  Const WkshtDestName As String = "Sheet2"   ' / with the names of your worksheets
  Const ColSupplier As String = "A"          ' \ In Cells(R, C), C can be a
  Const ColProduct As String = "B"           ' / number or a column identifier
  Const RowDataFirst As Long = 1
Sub MergeRowsForSameSupplier()

  Dim ColCrnt As Long          ' \ Columns in source and destination are the
  Dim ColMax As Long           ' / same so single variables are adequate.
  Dim RowDestCrnt As Long      ' \ Rows in source and destination
  Dim RowSrcCrnt As Long       ' | worksheets are different
  Dim RowSrcMax As Long        ' / so need separate variables.

  Dim ProductCrnt As String
  Dim Join As String
  Dim SupplierCrnt As String
  Dim WkshtSrc As Worksheet
  Dim WkshtDest As Worksheet

  Set WkshtSrc = Worksheets(WkshtSrcName)
  Set WkshtDest = Worksheets(WkshtDestName)

  With WkshtSrc
    ' I consider this to be the easiest technique of identifying the last used
    ' row and column in a worksheet.  Note: the used range includes trailing
    ' rows and columns that are formatted but otherwise unused or were used but
    ' aren't now so other techniques can better match what the user or the
    ' programmer usually mean by "used".
    ColMax = .UsedRange.Columns.Count
    RowSrcMax = .UsedRange.Rows.Count
  End With

  With WkshtDest
    .Cells.EntireRow.Delete         ' Delete any existing contents
  End With

  RowDestCrnt = RowDataFirst

  For RowSrcCrnt = RowDataFirst To RowSrcMax
    With WkshtSrc
      SupplierCrnt = .Cells(RowSrcCrnt, ColSupplier).Value
      ProductCrnt = .Cells(RowSrcCrnt, ColProduct).Value
    End With
    If SupplierCrnt <> "" Then
      ' This is the first or only row for a supplier.
      ' Copy it to Destination worksheet.
      With WkshtSrc
        .Range(.Cells(RowSrcCrnt, 1), .Cells(RowSrcCrnt, ColMax)).Copy _
                              Destination:=WkshtDest.Cells(RowDestCrnt, 1)
      End With
      RowDestCrnt = RowDestCrnt + 1
    ElseIf ProductCrnt = "" Then
      ' Both Supplier and Product cells are empty.
      With WkshtSrc
        If .Cells(RowSrcCrnt, Columns.Count).End(xlToLeft).Column = 1 And _
           .Cells(RowSrcCrnt, 1).Value = "" And _
           .Cells(RowSrcCrnt, Columns.Count).Value = "" Then
          ' If you do not understand why I have so many tests,
          ' experiment with Ctrl+Left
          ' Row empty so ignore it
        Else
          ' Don't know what to do with this error so give up
          Call MsgBox("Cells " & ColSupplier & RowSrcCrnt & " and " & _
                      ColProduct & RowSrcCrnt & " of worksheet " & _
                      WkshtSrcName & _
                      " are blank but the entire row is not blank", _
                      vbOKOnly + vbCritical, "Merge rows for same supplier")
          Exit Sub
        End If
      End With
    Else
      ' Supplier cell is empty. Product cell is not.
      ' Row RowDestCrnt-1 of the Destination worksheet contains the first row
      ' for this supplier or the result of merging previous rows for this
      ' supplier.
      If WkshtSrc.Cells(RowSrcCrnt + 1, ColSupplier).Value = "" And _
         WkshtSrc.Cells(RowSrcCrnt + 1, ColProduct).Value <> "" Then
        ' The next row is for the same supplier but is not a blank row
        Join = ","
      Else
        ' This is last row for this supplier
        Join = " &"
      End If
      ' Add to list of products
      With WkshtDest
        .Cells(RowDestCrnt - 1, ColProduct).Value = _
            .Cells(RowDestCrnt - 1, ColProduct).Value & Join & " " & _
            ProductCrnt
      End With
      For ColCrnt = 1 To ColMax
        If ColCrnt = Cells(1, ColSupplier).Column Or _
           ColCrnt = Cells(1, ColProduct).Column Then
          ' You may think (and you may be right) that the supplier and product
          ' will always be in the first two columns.  But have seen the
          ' weirdest arrangements and make no assumptions
          ' Ignore this column
        Else
          If WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Value = "" Then
            ' The most likely arrangement: the subsequent row has no
            ' value in this column.  Nothing to do.
          ElseIf WkshtDest.Cells(RowDestCrnt - 1, ColCrnt).Value = "" Then
            ' This source row has a value in this column but [the] previous
            ' row[s] did not.
            ' Note: I use the copy statement because it copies formatting as
            ' well as the value which may be useful.
            WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Copy _
                             Destination:=WkshtDest.Cells(RowDestCrnt - 1, ColCrnt)
          ElseIf WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Value = _
                 WkshtDest.Cells(RowDestCrnt - 1, ColCrnt).Value Then
            ' Values match.  Nothing to do.
          Else
            ' Values do not match.
            ' Don't know what to do with this error so give up.
            Call MsgBox("The value in cell " & ColNumToCode(ColCrnt) & _
                        RowSrcCrnt & " of worksheet " & WkshtSrcName & _
                        " does not match a value in an earlier row " & _
                        "for the same supplier", _
                        vbOKOnly + vbCritical, "Merge rows for same supplier")
            Exit Sub
          End If
        End If
      Next
    End If
  Next

  With WkshtDest
    .Cells.Columns.AutoFit
  End With


End Sub
Function ColNumToCode(ByVal ColNum As Long) As String

  ' Convert a column identifier (A, AA, etc.) to its number

  Dim Code As String
  Dim PartNum As Long

  ' Last updated 3 Feb 12.  Adapted to handle three character codes.
  If ColNum = 0 Then
    ColNumToCode = "0"
  Else
    Code = ""
    Do While ColNum > 0
      PartNum = (ColNum - 1) Mod 26
      Code = Chr(65 + PartNum) & Code
      ColNum = (ColNum - PartNum - 1) \ 26
    Loop
  End If

  ColNumToCode = Code

End Function

合并单元格并删除重复数据

1 个答案: