复制具有条件的列 [英] Copy the columns with condition

问题描述

Hii，

我的Excel文件中有两个工作表，所以我想选择并在同一个工作簿中将列（Part_Number，Name，Version，Level）从sheet1复制到sheet2（级别）列包括单元格> 1.



下面的代码将工作表1中的列复制到工作表2，但我仍然无法设置条件

任何人都可以帮助我吗？

谢谢



我的尝试：

  Sub  OneCell（）
 Sheets（  sheet1）。选择 
范围（   A1：A100）。复制'  Part_Number列' 
范围（  F1 ：F100）。复制' 名称列' 
范围（  H1：H100）。复制' 版本列' 
范围（  M1：M100）。复制' 版本级别 
表格（  sheet2）。< span class =code-keyword>选择 
范围（  A1：A100).选择 
范围（  F1：F100）。选择 
范围（  H1：H100）。选择 
范围（  M1：M100）。选择 
 ActiveSheet.Paste 
 结束  Sub  

解决方案

假设你想要将数据从一张纸复制到另一张，当满足特定条件（级别> 1 ）时，您可以通过两种方式实现这一目的：

1. 使用 ADODB.Recordset [ ^ ] + Range.CopyFromRecordset方法 [ ^ ]
   
   这种方法非常快！
   
   < pre lang =vb> ' 需要引用Microsoft ActiveX数据对象库xx
   < span class =code-keyword> Sub CopyData1（）
   Dim oConn As ADODB.Connection，oRst As ADODB.Recordset
   Dim sConn 作为 字符串，sSql 作为 字符串
   
   开启 错误 GoTo Err_CopyData1
   
   ' 将连接字符串定义为自身（此工作簿）
   sConn = Provider = Microsoft.ACE.OLEDB.12.0;数据源=& ThisWorkbook.FullName& ;扩展属性='Excel 12.0宏; HDR = YES';
   ' 创建并打开连接
   设置 oConn = 新 ADODB.Connection
   使用 oConn
   .ConnectionString = sConn
   。打开
   结束 使用
   ' 定义查询
   sSql = SELECT [Part_Number]，[Name]，[Version]，[Level]& vbCr& _
   FROM [Sheet1

A1：D100]& vbCr& _
WHERE [Level]> 1;
创建和打开记录集
设置 oRst = 新 ADODB.Recordset
oRst.Open sSql，oConn，adOpenStatic，adLockReadOnly

' context !!!
使用 ThisWorkbook.Worksheets（ Sheet2）
' 清晰的宝贵数据
.Range（ A2：D10000 ）。删除xlShiftUp
' 插入过滤数据
。范围（ A2）。CopyFrom记录集oRst
结束 使用

' 退出子程序
Exit_CopyData1：
' 忽略错误并清理
开启 错误 恢复 下一步
如果 不 oConn 没什么 然后 oConn.Close
设置 oConn = Nothing
如果 不 oRst 是 没什么 n oRst.Close
Set oRst = Nothing
退出 Sub

' 错误处理程序
Err_CopyData1：
MsgBox Err.Description，vbExclamation，Err.Number
恢复 Exit_CopyData1
结束 Sub

使用进行...下一步或执行/循环循环

此方法比上述方法慢。

  Sub  CopyData2（）
  Dim  srcWsh 作为工作表，dstWsh 作为工作表
  Dim  i 作为 整数， j 作为 整数 
 
 开 错误  GoTo  Err_CopyData2 
 
 ' 定义上下文 
 设置 srcWsh = ThisWorkbook.Worksheets（< span class =code-string>  Sheet1）
 设置 dstWsh = ThisWorkbook.Worksheets（  Sheet2）
 
  清除范围 
 dstWsh.Range（   A2：D10000）。清除
 
 ' 起始行 
i =  2  
j =  2  
 ' 循环数据 
     srcWsh.Range（  A& i）<>   
 ' < span class =code-comment>如果Level等于1，则跳过soubroutine  
 如果 srcWsh.Range（  D& i）=  1  然后  GoTo  SkipThisRow 
 ' 列的副本集 - 在本例中为A到D，但它可能是：A，C，E，G  
  With  dstWsh 
 .Range（  A& j）= srcWsh。范围（  A& i）
 .Range（  B& j）= srcWsh.Range（  B& i）
 .Range（  C& j）= srcWsh.Range（< span class =code-string>  C& i）
 .Range（  D& j）= srcWsh.Range（  D& i）
 结束 使用 
 ' 增加Sheet2中的行号 
j = j +  1  
 ' 跳过子程序 
 SkipThisRow ：
 ' 增加Sheet1中的行号 
i = i +  1  
 循环 
 
 ' 退出子程序 
 Exit_CopyData2：
 开启 错误 恢复 下一步 
 设置 srcWsh = 无 
 设置 dstWsh = 没什么 
 退出  Sub  
 
 ' 错误处理程序 
 Err_CopyData2：
 MsgBox Err.Description，vbExclamation，Err.Number 
 恢复 Exit_CopyData2 
 结束  Sub  

选择您喜欢的方法。根据需要更改代码。最后，请阅读有关 Excel VBA性能编码最佳实践的MSDN文章 [ ^ ]





我已根据此问题向CodeProject数据库添加了源文件的文章/文章。您可以在您的机器上下载并测试。

请参阅：使用VBA在Excel表格之间复制数据 [ ^ ]

这是一种方法：

 选项 明确 
 公开  Sub  CopyColumns（）
 
  Dim  targetRow  As  整数 
 targetRow =  1  
 
  Dim  sourceRow  As  整数 
 对于 sourceRow =  1   工作表（ 1 ）。UsedRange。 Rows.Count 
 
  Dim  r  As 范围
 设置 r =工作表（ 1 ）。范围（  M +  CStr （sourceRow））
 如果 r.Value2>  1  然后 
 
工作表（ 1 ）。激活
工作表（ 1 ）。范围（  +  CStr （sourceRow）+  < span class =code-string>，F +  CStr （sourceRow）+  ，H +  CStr （sourceRow）+  ，M +  CStr （sourceRow））。选择 
 Selection.Copy 
 
工作表（ 2 ）。激活
工作表（ 2 ）。范围（  A +  CStr （targetRow））。选择 
 ActiveSheet.Paste 
 
 targetRow = targetRow +  1  
 结束 如果 
 下一步 
 
 结束  Sub  

有些注意事项：

- 别忘了激活或在复制或粘贴之前选择每个工作表，否则会得到（无用的）错误

Quote：

----------- ----------------

Microsoft Visual Basic for Applications

------------- --------------

运行时错误'1004'：



应用程序定义或对象定义的错误

---------------------------

OK Help

----------------------- ----

- 请注意我选择要复制的项目范围的方式。对于第1行，该范围将类似于工作表（1）。范围（A1，F1，H1，M1）。选择

- I已经使用了每个工作表的索引而不是名称Sheet1，Sheet2 - 如果有人重命名它们，这个sub仍然可以工作。

- 我使用了 UsedRange 为源工作表，所以这个子将跳过数据中的空白。

- 我正在检查 Value2 （不是值或文本）以确保我获得单元格的实际内容（无论格式或列的宽度）

Hii,
I have two worksheets in my Excel file, so i want to select and copy the columns (Part_Number,Name,Version,Level) from sheet1 to sheet2 in same workbook when the (Level) column include cell >1.

the below code copy the columns from worksheet 1 to work sheet 2,but i still can not set the condition
any one can help me?
Thanks

What I have tried:

Sub OneCell()
    Sheets("sheet1").Select
    Range("A1:A100").Copy    'Part_Number column'
    Range("F1:F100").Copy    'Name column'
    Range("H1:H100").Copy     'Version column'
    Range("M1:M100").Copy     'Version Level'
    Sheets("sheet2").Select
    Range("A1:A100").Select
    Range("F1:F100").Select
    Range("H1:H100").Select
    Range("M1:M100").Select
    ActiveSheet.Paste
End Sub

解决方案

Assuming that you want to copy data from one sheet into another, when specific condition is meet (Level>1), you can achieve that in two ways:

1. Using ADODB.Recordset[^] + Range.CopyFromRecordset method[^]
   This method is really fast!
   

   'needs reference to Microsoft ActiveX Data Object Library x.x
   Sub CopyData1()
   Dim oConn As ADODB.Connection, oRst As ADODB.Recordset
   Dim sConn As String, sSql As String
   
   On Error GoTo Err_CopyData1
   
   'define conection string to itself (this workbook)
   sConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0 Macro;HDR=YES';"
   'create and open connection
   Set oConn = New ADODB.Connection
   With oConn
       .ConnectionString = sConn
       .Open
   End With
   'define query
   sSql = "SELECT [Part_Number], [Name], [Version], [Level]" & vbCr & _
       "FROM [Sheet1

A1:D100]" & vbCr & _ "WHERE [Level]>1;" 'create and open recordset Set oRst = New ADODB.Recordset oRst.Open sSql, oConn, adOpenStatic, adLockReadOnly 'context!!! With ThisWorkbook.Worksheets("Sheet2") 'clear precious data .Range("A2:D10000").Delete xlShiftUp 'insert filtered data .Range("A2").CopyFromRecordset oRst End With 'exit subroutine Exit_CopyData1: 'ignore errors and clean up On Error Resume Next If Not oConn Is Nothing Then oConn.Close Set oConn = Nothing If Not oRst Is Nothing Then oRst.Close Set oRst = Nothing Exit Sub 'error handler Err_CopyData1: MsgBox Err.Description, vbExclamation, Err.Number Resume Exit_CopyData1 End Sub

Using for... next or Do/While Loop loop
This method is slower than above.

Sub CopyData2()
Dim srcWsh As Worksheet, dstWsh As Worksheet
Dim i As Integer, j As Integer

On Error GoTo Err_CopyData2

'define context
Set srcWsh = ThisWorkbook.Worksheets("Sheet1")
Set dstWsh = ThisWorkbook.Worksheets("Sheet2")

'clear range before you start copying
dstWsh.Range("A2:D10000").Clear

'starting rows
i = 2
j = 2
'loop though the data
Do While srcWsh.Range("A" & i) <> ""
    'go to skip soubroutine if Level is equal to 1
    If srcWsh.Range("D" & i) = 1 Then GoTo SkipThisRow
    'copy set of columns - in this case A to D, but it might be: A, C, E, G
    With dstWsh
        .Range("A" & j) = srcWsh.Range("A" & i)
        .Range("B" & j) = srcWsh.Range("B" & i)
        .Range("C" & j) = srcWsh.Range("C" & i)
        .Range("D" & j) = srcWsh.Range("D" & i)
    End With
    'increase row number in Sheet2
    j = j + 1
'skip subroutine
SkipThisRow:
    'increase row number in Sheet1
    i = i + 1
Loop

'exit subroutine
Exit_CopyData2:
    On Error Resume Next
    Set srcWsh = Nothing
    Set dstWsh = Nothing
    Exit Sub

'error handler
Err_CopyData2:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_CopyData2
End Sub

Choose the method you prefer. Change the code to your needs. And finally, please read MSDN article about Excel VBA Performance Coding Best Practices[^]

[EDIT]
I've added tip/article with source file to CodeProject database based on this question. You can download it and test on your machine.
Please, see: Copy Data Between Excel Sheets using VBA[^]

Here is one way of doing it:

Option Explicit
Public Sub CopyColumns()

    Dim targetRow As Integer
    targetRow = 1
    
    Dim sourceRow As Integer
    For sourceRow = 1 To Worksheets(1).UsedRange.Rows.Count
                
        Dim r As Range
        Set r = Worksheets(1).Range("M" + CStr(sourceRow))
        If r.Value2 > 1 Then
            
            Worksheets(1).Activate
            Worksheets(1).Range("A" + CStr(sourceRow) + ",F" + CStr(sourceRow) + ",H" + CStr(sourceRow) + ",M" + CStr(sourceRow)).Select
            Selection.Copy

            Worksheets(2).Activate
            Worksheets(2).Range("A" + CStr(targetRow)).Select
            ActiveSheet.Paste
            
            targetRow = targetRow + 1
        End If
    Next
    
End Sub

Some things to note:
- don't forget to Activate or Select each sheet before you copy or paste otherwise you will get an (unhelpful) error

Quote:

---------------------------
Microsoft Visual Basic for Applications
---------------------------
Run-time error '1004':

Application-defined or object-defined error
---------------------------
OK Help
---------------------------

- Note the way I've selected the range of items to copy. For row 1 that range will look like Worksheets(1).Range("A1,F1,H1,M1").Select
- I've used the index for each sheet rather than names "Sheet1", "Sheet2" - if someone renames them this sub will still work.
- I've used the UsedRange for the source worksheet so this sub will skip over gaps in the data.
- I'm checking against Value2 (not Value or Text) to ensure I get the actual contents of the cell (regardless of formatting, or width of column)

这篇关于复制具有条件的列的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！