简体   繁体   English

Excel VBA,复制彩色行

[英]Excel VBA, Copying Colored Rows

I have a list in "Sheet1" with three Columns, A (Account Number), B (Description) & C (Amount). 我在“ Sheet1”中有一个带有三列的列表,A(帐号),B(描述)和C(金额)。 Based on 1st two columns (A & B) color, I want to copy the specific row to "Sheet2" and Paste it under one specific header (I have three headers). 基于第一两列(A和B)的颜色,我想将特定的行复制到“ Sheet2”,并将其粘贴到一个特定的标题下(我有三个标题)。

Example

  1. Sheet1 - Cell A2 is "Red" & B2 is "Yellow", Copy/Paste Under Header "Inefficiencies" in Sheet2 Sheet1-单元格A2为“红色”,B2为“黄色”,在Sheet2的标题“ Inefficiency”下复制/粘贴
  2. Sheet1 - Cell A3 is "Blue" & B3 is "No Color" Copy/Paste Under Header "Effective" in Sheet2 Sheet1-单元格A3为“蓝色”,B3为“无颜色”复制/粘贴在Sheet2的标题“有效”下

Account Number  Description  Amount
LP001022        Graduate     3,076.00 
LP001031        Graduate     5,000.00 
LP001035        Graduate     2,340.00 

I have taken a code from this site already, but I could not completely configure it to my needs. 我已经从该站点获取了一个代码,但是我无法完全根据需要配置它。 Thank you for the help in advance. 谢谢您的帮助。

Sub lastrow()
    Dim lastrow As Long
    Dim i As Long, j As Long
    Dim acell As Range

    With Worksheets("Sheet1")
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    MsgBox (lastrow)

    With Worksheets("Sheet3")
        j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    End With

    For i = 1 To lastrow
        With Worksheets("Sheet1")
            If .Cells(i, 1).Interior.Color = RGB(255, 255, 0) And _
               .Cells(i, 1).Interior.ColorIndex = xlNone Then
                   .Rows(i).Copy 'I have to give destination 
                   j = j + 1
                End If
        End With
    Next i
End Sub

Here are the key instructions to copy a row from sheet1 to INSERT into a row in sheet2. 这是将一行从sheet1复制到INSERT并复制到sheet2中的一行的主要说明。 This assumes you have all the row numbers. 假定您具有所有行号。

' -- to copy a row in sh1 to INSERT into sh2:
  sh2.Rows(irowInefficiency + 1).Insert
  sh1.Rows(irowFrom).Copy sh2.Rows(irowInefficiency + 1)
' -- you have to increment all header rows after this one
  irowEffective = irowEffective + 1

The following puts these in context: 下面将它们放在上下文中:

Sub sub1() ' copy/insert a row
  Dim irowFrom&, irowInefficiency&, irowEffective&
  Dim sh1, sh2 As Worksheet
  Set sh1 = Sheets("sheet1")
  Set sh2 = Sheets("sheet2")
  irowInefficiency = 3 ' where that header is
  irowEffective = 6 ' where that header is
  irowFrom = 5 ' the row to copy
' -- to copy a row in sh1 to INSERT into sh2:
  sh2.Rows(irowInefficiency + 1).Insert ' a blank row
  sh1.Rows(irowFrom).Copy sh2.Rows(irowInefficiency + 1) ' then copy
' -- you have to increment all header rows after this one
  irowEffective = irowEffective + 1 ' because it increases
End Sub

声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM