如何确定作为小计的彩色格式化单元格的行范围，并跨多列应用？

我真的很新的VBA代码，并试图改善做得更好。 需要帮助，如果有人可以帮助我进一步在我的代码。 感谢您的耐心提前。

我想要实现的是通过一个多行和多列的表来运行代码，以将选定的范围复制到同一工作簿的另一个工作表中。 我试图确定哪些单元格的颜色格式化（如.H2）。 一旦确定，我想要回到同一行的第一列（在这个例子中，它将是A2）。 然后，从列中运行代码，查看重复的名称（列A是名称）。 一旦检测到一个不同的名称源，我想复制第一个名字的范围（在这个例子中，它将是A2），复制到多个列（列A到newlastcol）的姓氏（例如，A6）。 A7被发现是一个不同的名字。

表A中的A列数据已经从Asorting到Z，颜色格式化的单元格是为相同名称计算的小计，总是显示在顶部。 它的行号永远是列A中的第一个名字。

Dim StartTest As Range, StartName As Range Dim lastrow As Integer, lastcol As Integer Dim R As Integer, C As Integer Dim i As Long, j As Long, k As Long 'Filter off Coloured Cells Set StartTest = Cells(1, 1) StartTest.Select Do Until IsEmpty(ActiveCell) newlastrow = ActiveCell.Row ActiveCell.Offset(1, 0).Select Loop StartTest.Select Do Until IsEmpty(ActiveCell) newlastcol = lastcol + 1 ActiveCell.Offset(0, 1).Select Loop NextColumn: C = StartTest(1).Column R = StartTest(1).Row Set filterrng = Range(Cells(R, C), Cells(newlastrow, C)) Cells(1, C).Select If IsEmpty(ActiveCell) = True Then GoTo NextPart End If For j = 2 To newlastrow Cells(j, C).Select If Cells(j, C).Interior.Color = 255 Then Cells(j, 1).Select **'Problem Line** Set StartName = Cells(j, 1) NameC = StartName(1).Column NameR = StartName(j).Row StartName.Select For k = NameR To newlastrow If Cells(NameR, NameC) <> Cells(NameR + 1, NameC) Then namelastrow = k Range(Cells(NameR, NameC), Cells(namelastrow, newlastcol)).Select Selection.Copy End If Set StartName = StartName.Offset(1, 0) Next k End If Next j Cells(R, C + 1).Select Set filterrng = filterrng.Offset(0, 1) Set StartTest = StartTest.Offset(0, 1) GoTo NextColumn End Sub 

我可以让代码在多列中运行，并且可以将光标放回到列（A2）的同一行的单元格中。 但是我有'StartDate部分'的问题，它是检查同一列或多行内的重复名称并突出显示要复制到另一个表中的范围的部分。

提前感谢大家的反馈。 真的很感激，如果有其他的build议或build议。

Answer 1

直到StrComp（ActiveCell.Value，ActiveCell.Offset（1，0）.Value）= True或IsEmpty（ActiveCell.Value）

  ActiveCell.Resize(1, 5).Copy ActiveCell.Offset(1, 0).Select Sheets("C").Activate ActiveCell.PasteSpecial ActiveCell.Offset(1, 0).Select Sheets("AB").Activate Loop 

万一

 Range("g3").Select If ActiveCell.Interior.Color = RGB(255, 255, 0) Then Range("a1:a30").Find(what:="yelow").Activate Do Until StrComp(ActiveCell.Value, "yelow") = True Or IsEmpty(ActiveCell.Value) ActiveCell.Resize(1, 5).Copy ActiveCell.Offset(1, 0).Select Sheets("C").Activate ActiveCell.PasteSpecial ActiveCell.Offset(1, 0).Select Sheets("AB").Activate Loop End If Loop 

ActiveCell.Offset（1，0）。select