【问题标题】：Create VBA for multiple sheet and copy paste in new column with formula为多个工作表创建 VBA 并使用公式在新列中复制粘贴
【发布时间】：2016-10-17 14:35:27
【问题描述】：

我有一个包含多张工作表的 Excel，我想复制或更好地说想每个月扩展最后一列。

例如：- 我有一张名为 sheet1,sheet2,sheet3,sheet4,sheet5 的工作表...月底的每张工作表都有公式。一个月结束后，我想添加一个包含新月份的新列并复制现有的公式到新列。假设我有上个月一月，我需要 VBA 添加新列，月份为二月并将所有公式复制到新列。

有时我还需要复制多列（例如：C-J 列）并使用新月份和公式复制接下来的 8 列。

尝试使用录制宏，但问题是它不会为每个月创建一个新列，它只是将其复制粘贴到同一列中，而不是为每个月创建一个新列

【问题讨论】：

您是在处理来自不同工作表的数据，还是在汇总表上复制一列并想要更新新列中的公式？
你能发布你的公式吗？这可以在没有 VBA 的情况下轻松完成。
Nope.All 我想做的是有多个工作表，我想扩展相同的公式。 ' Macro4 宏 ' ' Application.Calculation = xlManual Sheets(Array("Shee1", "Sheet2", "Sheet3", "Sheet4", "Sheet5"))。 _ 选择 Sheets("Sheet1").Activate Columns("AN:AN").Select Selection.AutoFill Destination:=Columns("AN:AO"), Type:=xlFillDefault Columns("AN:AO").Select End Sub 上面是宏，所以每次都从 AN 复制并复制到 AN:AO 。下次填充 AO 时我想要它现在应该从 AO 复制并移动到 AP
我指的是你的工作表公式。不是你的宏。
它是多行上的 sumifs、add、subtract 和百分比的多个公式。我想要的只是将相同的内容从最后一列复制到下一列，所以一旦我只提供数据，所有数据都会按照作为 sumifs 可以做的新月份

标签： vba excel

【解决方案1】：

不看公式很难理解问题。

听起来您可以从使用自动填充开始。您可以通过选择要复制的范围并拖动右下角的十字来手动执行此操作。这将自动更新月份。

你可以用VBA实现这个，比如：

Public Sub copyRange()
    Dim rngSource As Range
    Dim rngDestination As Range

    rngSource = ActiveSheet.Range("A1:A20")
    rngDestination = ActiveSheet.Range("B1:B20")

    rngSource.AutoFill Destination:=rngDestination
End Sub

不管怎样，如果没有看到单元格代码，我不知道如何重置新月份的公式。

更新：自动填充多个选项卡上的多个列

Public Sub copySpecifiedColumns()
    copyRanges InputBox("How many columns do you wish to copy?", "Copy Columns", "1")
End Sub
Private Sub copyRanges(copyCols As Byte)
    Dim ws As Worksheet, lastCol As Integer, lastRow As Integer
    Dim rngSource As Range, rngDestination As Range
    Dim sheetList As Variant
    sheetList = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")

    For Each ws In ThisWorkbook.Sheets
        If (UBound(Filter(sheetList, ws.Name)) > -1) Then
            lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
            lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            Set rngSource = ws.Range(ws.Cells(1, lastCol - copyCols + 1), _
                ws.Cells(lastRow, lastCol))
            Set rngDestination = ws.Range(ws.Cells(1, lastCol - copyCols + 1), _
                ws.Cells(lastRow, lastCol + copyCols))

            rngSource.AutoFill rngDestination
        End If
    Next ws
End Sub

【讨论】：

下面是宏'Macro4 Macro'' Application.Calculation = xlManual Sheets(Array("Shee1", "Sheet2", "Sheet3", "Sheet4", "Sheet5"))。 _ 选择 Sheets("Sheet1").Activate Columns("AN:AN").Select Selection.AutoFill Destination:=Columns("AN:AO"), Type:=xlFillDefault Columns("AN:AO").Select End Sub 上面是宏，所以每次都从 AN 复制并复制到 AN:AO 。下次填充 AO 时我想要它现在应该从 AO 复制并移动到 AP
感谢部分解决了我的问题。但我无法看到选择了多张纸的位置。对于我想要的唯一一张纸来说，它工作正常，对于多张纸，如表格 1、表格 2、表格 3 等.
我明白了。尽管您的代码包含一个工作表名称数组，但它会选择 Sheet1，忽略该数组，所以我认为这是您想要应用自动填充的地方。我已经更新了答案末尾的代码，以根据数组中保存的名称迭代工作表。希望这对你有用。
如果要复制工作簿中所有工作表中的范围，可以删除 If 语句和数组。
我用工作表名称更新了数组，但现在出现错误“Range 类的自动填充方法失败..

【解决方案2】：

我同意，要在这里理解您想要实现的目标有点困难。据我了解，如果您想在每张纸的下一列中复制最后一列并将该列的第一个单元格更改为当时的月份。此代码可以提供帮助。

Sub copy_col()


Dim lColumn As Long
For Each Sheet In Worksheets

lColumn = Sheet.Cells(1, Columns.Count).End(xlToLeft).Column
Sheet.Columns(lColumn).Copy Sheet.Columns(lColumn + 1)
Sheet.Cells(1, lColumn + 1).Value = Month(Now())

Next Sheet
End Sub

如果这不是您想要的，请更简要地解释您的问题。

谢谢

【讨论】：

Nope.All 我想做的是有多个工作表，我想扩展相同的公式。 ' Macro4 宏 ' ' Application.Calculation = xlManual Sheets(Array("Shee1", "Sheet2", "Sheet3", "Sheet4", "Sheet5"))。 _ 选择 Sheets("Sheet1").Activate Columns("AN:AN").Select Selection.AutoFill Destination:=Columns("AN:AO"), Type:=xlFillDefault Columns("AN:AO").Select End Sub 上面是宏，所以每次都从 AN 复制并复制到 AN:AO 。下次填充 AO 时我想要它现在应该从 AO 复制并移动到 AP

【解决方案3】：

扩展列表和更新公式

用法

ExtendList 5，“Sheet1”，“Sheet3”

在哪里 1. 5，是要复制到下一个空Column的Column 2.“Sheet1”是原公式中引用的工作表 3.“Sheet3”为替换表名

原始配方

=Sheet1!$A10

新配方

=Sheet3!$A10

Sub ExtendList(SourceColumn As Long, OriginalSheetName As String, NewSheetName As String)
    On Error Resume Next
    Dim newColumnNumber As Integer
    Worksheets(NewSheetName).Name = NewSheetName
    If Err.Number <> 0 Then
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0
    
    newColumnNumber = Range(Cells(1, Columns.Count), Cells(Rows.Count, Columns.Count)).End(xlToLeft).Offset(, 1).Column

    Columns(SourceColumn).Copy Columns(newColumnNumber)
    
    Columns(newColumnNumber).Replace What:=OriginalSheetName, Replacement:=NewSheetName, lookat:=xlPart, _
        SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False

End Sub

这只有在列引用是绝对的时才有效：

正确

$A1 或 $A$2

不正确

A1 或 A$1

【讨论】：