VBA code调整 - 循环，复制到新的工作表 [英] VBA Code Adjustment - Loop, copy to new sheet

问题描述

我从Chandoo以下code为Excel。在数据表，它选择的表复制到根据山坳。 C，然后复制山坳。 A - G以那个S preadsheet并移动到下一个条目

I have the below code from Chandoo for excel. In the 'Data Sheet' it selects the sheet to copy to according to col. C, then copies col. A - G to that spreadsheet and moves to the next entry.

我无法调整该code，以满足我的小号preadsheet并且将AP preciate一些帮助。我的工作表名称在山坳。 A（不是C），而我只需要山坳。 B＆安培; C到被复制到片材。此外山坳。 B＆安培; C，则需要被复制到山坳。 B＆安培;在s preadsheet -G。

I am having trouble adjusting this code to suit my spreadsheet and would appreciate some assistance. My sheet name is in col. A (not c), and I only require col. B & C to be copied to the sheet. Additionally col. B & C need to be copied into col. B & G in the spreadsheet.

Sub copyPasteData()
    Dim strSourceSheet As String
    Dim strDestinationSheet As String
    Dim lastRow As Long

    strSourceSheet = "Data entry"

    Sheets(strSourceSheet).Visible = True
    Sheets(strSourceSheet).Select

    Range("C2").Select
    Do While ActiveCell.Value <> ""
        strDestinationSheet = ActiveCell.Value
        ActiveCell.Offset(0, -2).Resize(1, ActiveCell.CurrentRegion.Columns.Count).Select
        Selection.Copy
        Sheets(strDestinationSheet).Visible = True
        Sheets(strDestinationSheet).Select
        lastRow = LastRowInOneColumn("A")
        Cells(lastRow + 1, 1).Select
        Selection.PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        Sheets(strSourceSheet).Select
        ActiveCell.Offset(0, 2).Select
        ActiveCell.Offset(1, 0).Select
    Loop
End Sub

Public Function LastRowInOneColumn(col)
    'Find the last used row in a Column: column A in this example
    'http://www.rondebruin.nl/last.htm
    Dim lastRow As Long
    With ActiveSheet
    lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
    End With
    LastRowInOneColumn = lastRow
End Function

在解决这将是极大的AP preciated任何帮助。

Any assistance in resolving this would be greatly appreciated.

感谢您

推荐答案

这是在抄袭随机code形成了互联网的危险一联盛。操纵这样的活动选择很慢，难以阅读，并难于维护。

This is a leason on the dangers of copying random code form the internet. Manipulating the active selection like this is slow, hard to read, and hard to maintain.

这里的code重构做这个任务更可控FASION。

Here's the code refactored to do this task in a more controlled fasion.

该origonal code（重构）计算在内，注释掉。修改为引用您的请求细胞中的code如下每个原始行

The origonal code (refactored) is included, commented out. The code modified to reference your requested cells follows each original line

Sub copyPasteData()
    Dim strSourceSheet As String
    Dim strDestinationSheet As String
    Dim lastRow As Long

    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim rWs As Range
    Dim rSrc As Range, rDst As Range, cl As Range

    strSourceSheet = "Data entry"
    ' Get a reference to the source sheet
    Set wsSource = Worksheets(strSourceSheet)

    With wsSource
        ' Get a reference to the list of sheet names
        'Set rWs = Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp))  ' for Column C
        Set rWs = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))  ' for Column A

        ' Loop through the sheet names list
        For Each cl In rWs.Cells
            ' Get a reference to the current row of data, all cells on that row
            'Set rSrc = cl.EntireRow.Resize(1, .Cells(cl.Row, .Columns.Count).End(xlToLeft).Column)
            Set rSrc = cl.EntireRow.Cells(1, 2).Resize(1, 2)  ' Reference columns B and C only

            ' Get a reference to the current Destination sheet
            Set wsDest = Worksheets(cl.Value)
            With wsDest
                lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row  ' Check last row in Column B
                ' Copy data to destination using Value array
                '.Cells(lastRow + 1, 1).Resize(1, rSrc.Columns.Count).Value = rSrc.Value  ' all data
                .Cells(lastRow + 1, 2).Value = rSrc.Cells(1, 1) ' copy first cell to column B
                .Cells(lastRow + 1, 7).Value = rSrc.Cells(1, 2) ' copy second cell to column G
            End With
        Next
    End With
End Sub

这篇关于VBA code调整 - 循环，复制到新的工作表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！