Excel循环遍历行并将单元格值复制到另一个工作表 [英] Excel Looping through rows and copy cell values to another worksheet

问题描述

意图

/ strong>：

我有表（输入）.column A 中的数据列表具有值的行将有所不同，因此我创建了一个循环，将运行宏直到活动单元为空）。

我的宏从 Range（A2）开始，并且一直延伸到A列，只有当它点击空行

宏的期望结果是开始复制 sheet（input）中的单元格.Range（A2）将其粘贴到 sheet（mywork）.Range（B2：B6）。

如果Peter是单元格 sheet（input），range（A2）中的值，那么当marco运行并将该值粘贴到 sheet（ mywork）范围（B2：B6）。即范围 B2：B6 将反映Peter

然后宏循环回到表（输入）&复制下一个单元格值并将其粘贴到范围（B7：B10）

示例：Dave是 sheet（input）Range（A3）中的值，然后Dave将粘贴到中的下一行中片（MYWORK）.Range（B7：B10）。 B7：B10 将反映Dave

再次重复相同的过程返回页面（输入） range（A4），将值转到表格（mywork）并将其粘贴到 B11：B15 中。 p>

基本上该过程重复....

宏在表单（输入）列A 为空。

  Sub playmacro（）
 Dim xxx As Long，yyy As Long 
 ThisWorkbook.Sheets（Input）。Range（A2）。Activate 
 Do While ActiveCell.Value<> 
 DoEvents 
 ActiveCell.Copy 
对于xxx = 2至350步骤4 
 yyy = xxx + 3 
工作表（mywork）。激活
使用ActiveSheet 
 .Range（Cells（xxx，2），Cells（yyy，2））。PasteSpecial xlPasteValues 
 End With 
 Next xxx 
 ThisWorkbook.Sheets（Input ）。选择
 ActiveCell.Offset（1，0）.Activate 
循环
 Application.ScreenUpdating = True 
 End Sub 
  pre> 
 
解决方案
 
  Private Sub CommandButton1_Click（）
 
 Dim Z As Long 
 Dim Cellidx As Range 
 Dim NextRow As Long 
 Dim Rng As Range 
 Dim SrcWks As Worksheet 
 Dim DataWks As Worksheet 
 Z = 1 
 Set SrcWks = Worksheets（Sheet1）
设置DataWks =工作表（Sheet2）
设置Rng = EntryWks.Range（B6：ad6）
 
 NextRow = DataWks.UsedRange.Rows.Count 
 NextRow = IIf（NextRow = 1，1， NextRow + 1）
 
对于每个RA在Rng.Areas 
对于每个Cellidx在RA 
 Z = Z + 1 
 DataWks.Cells（NextRow，Z）= Cellidx 
下一个Cellidx 
下一个RA 
 End Sub 
  
 / p> 
 
 
 工作表（Sheet2）。范围（P2）值=工作表（Sheet1）。范围（L10 ）
  
这是一个CopynPaste  - 方法
  Sub CopyDataToPlan（）
 
 Dim LDate As String 
 Dim LColumn As Integer 
 Dim LFound As Boolean 
 
关于错误GoTo Err_Execute 
 
'检索日期值以搜索
 LDate =表（滚动计划）。范围（B4）。价值
 
表格（计划）选择
 
'从列B开始
 LColumn = 2 
 LFound = False 
 
虽然LFound = False 
 
'在第2行遇到空白单元格，终止搜索
如果Len（Cells（2，LColumn））= 0然后
 MsgBox找不到匹配日期。 
退出Sub 
 
'在行2中找到匹配
 ElseIf单元格（2，LColumn）= LDate然后
 
'选择要从滚动选择
范围（B5：H6）选择
 Selection.Copy 
 
'粘贴到计划选择
单元格（3，LColumn）。选择
 Selection.PasteSpecial粘贴：= xlValues，操作：= xlNone，SkipBlanks：= _ 
 False，Transpose：= False 
 
 LFound = True 
 MsgBox数据已成功复制。 
 
'继续搜索
 Else 
 LColumn = LColumn + 1 
如果
 
 Wend 
 
退出子
 
 Err_Execute：
 MsgBox发生错误。 
 
 End Sub 
  
在Excel中可能会有一些方法。 
 
I am facing some difficulty in achieving the desired result for my macro.

Intention:

I have a list of data in sheets(input).column A (the number of rows that has value will vary and hence I created a loop that will run the macro until the activecell is blank). 

My macro starts from Range(A2) and stretches all the way down column A, it stops only when it hits a blank row

Desired result for the macro will be to start copying the cell value in sheet(input).Range(A2) paste it to sheet(mywork).Range(B2:B6).

For example, if "Peter" was the value in cell sheet(input),range(A2) then when the marco runs and paste the value into sheet(mywork) range(B2:B6). ie range B2:B6 will reflect "Peter"

Then the macros loop back to sheet(input) & copy the next cell value and paste it to range(B7:B10)

Example: "Dave" was the value in sheet(input) Range(A3), then "Dave" will be paste into the next 4 rows in sheet(mywork).Range(B7:B10). B7:B10 will reflect "Dave"

Again repeating the same process goes back to sheet(input) this time range(A4), copys the value goes to sheet(mywork) and paste it into B11:B15.

Basically the process repeats....

The macro ends the when the activecell in sheet(input) column A is empty.
Sub playmacro()
    Dim xxx As Long, yyy As Long
    ThisWorkbook.Sheets("Input").Range("A2").Activate
    Do While ActiveCell.Value <> ""
        DoEvents
        ActiveCell.Copy
        For xxx = 2 To 350 Step 4
            yyy = xxx + 3
            Worksheets("mywork").Activate 
            With ActiveSheet
                .Range(Cells(xxx, 2), Cells(yyy, 2)).PasteSpecial xlPasteValues
            End With
        Next xxx
        ThisWorkbook.Sheets("Input").Select
        ActiveCell.Offset(1, 0).Activate
    Loop
    Application.ScreenUpdating = True
End Sub

解决方案
Private Sub CommandButton1_Click() 

Dim Z As Long 
Dim Cellidx As Range 
Dim NextRow As Long 
Dim Rng As Range 
Dim SrcWks As Worksheet 
Dim DataWks As Worksheet 
Z = 1 
Set SrcWks = Worksheets("Sheet1") 
Set DataWks = Worksheets("Sheet2") 
Set Rng = EntryWks.Range("B6:ad6") 

NextRow = DataWks.UsedRange.Rows.Count 
NextRow = IIf(NextRow = 1, 1, NextRow + 1) 

For Each RA In Rng.Areas 
    For Each Cellidx In RA 
        Z = Z + 1 
        DataWks.Cells(NextRow, Z) = Cellidx 
    Next Cellidx 
Next RA 
End Sub
Alternatively
Worksheets("Sheet2").Range("P2").Value = Worksheets("Sheet1").Range("L10") 
This is a CopynPaste - Method
Sub CopyDataToPlan()

Dim LDate As String
Dim LColumn As Integer
Dim LFound As Boolean

On Error GoTo Err_Execute

'Retrieve date value to search for
LDate = Sheets("Rolling Plan").Range("B4").Value

Sheets("Plan").Select

'Start at column B
LColumn = 2
LFound = False

While LFound = False

  'Encountered blank cell in row 2, terminate search
  If Len(Cells(2, LColumn)) = 0 Then
     MsgBox "No matching date was found."
     Exit Sub

  'Found match in row 2
  ElseIf Cells(2, LColumn) = LDate Then

     'Select values to copy from "Rolling Plan" sheet
     Sheets("Rolling Plan").Select
     Range("B5:H6").Select
     Selection.Copy

     'Paste onto "Plan" sheet
     Sheets("Plan").Select
     Cells(3, LColumn).Select
     Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
     False, Transpose:=False

     LFound = True
     MsgBox "The data has been successfully copied."

     'Continue searching
      Else
         LColumn = LColumn + 1
      End If

   Wend

   Exit Sub

Err_Execute:
  MsgBox "An error occurred."

End Sub
And there might be some methods doing that in Excel.

                        
这篇关于Excel循环遍历行并将单元格值复制到另一个工作表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！