Question

我的问题如下。

我为不同的客户提供了多张具有相同表格（价格）的表格（每张表格都是客户）。我必须每天更新价格列，方法是将价格复制到更过时的价格左侧。

作为示例，请参见下图：

所以我需要复制最后一行（z-sprd）并插入最后一个可用日期的LEFT（在下图中是6/11/2018）。到现在为止，我能够遍历工作表，找到z-sprd列并在某个地方通过它。我现在需要的是找到具有最新价格的列（在本例中为6/11/2018），我通过在工作表中放置一个用户窗体，然后插入并经过左侧的列。

Sub Sample()
    Dim ws As Worksheet
    Dim aCell As Range
    Dim bCell As Range
    Dim col As Long, lRow As Long
    Dim colName As String
    Dim i As Integer

    'Start of the VBA loop
    For i = 1 To Worksheets.Count

    Set ws = ThisWorkbook.Sheets(i)
    'Here i put the latest date, such as 6/11/2018, and then i find it in AC8
    Set bCell = Sheet1.UsedRange.Find(what:=Sheet1.Range("AC8").Value, LookIn:=xlValues, LookAt:=xlWhole, _
                    MatchCase:=False, SearchFormat:=False)
                    bCell.Copy Range("AD8")

    With ws
        Set aCell = .Range("Table").Find(what:="Z-Sprd (bp)", LookIn:=xlValues, LookAt:=xlWhole, _
                    MatchCase:=False, SearchFormat:=False)

    '~~> Copy the entire column
    aCell.EntireColumn.Copy


    '~~> Insert the column here
    With ws
       .Columns("AR:AR").PasteSpecial xlPasteValues
       .Columns("AR:AR").Resize(.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "0.0"
       bCell.Copy ws.Range("AR7")
       ws.Range("AR7") = ws.Range("AR7") + 7

    End With
    End With

    Next i

End Sub

Answer 1

我想出的解决方案就是这个：

Option Explicit


Sub LastPrices()
    Dim ws As Worksheet
    Dim aCell As Range
    Dim bCell As Range
    Dim selrange As Range
    Dim i As Integer
    Dim colnum As Integer, rownum As Integer
    Dim prj As Object
    Dim not_use As Variant


    Set prj = ActiveWorkbook.VBProject
    'Start of the VBA loop

    not_use = Array(2, 7, 8, 9, 10, 11) ' create an array

    For i = 1 To Worksheets.Count
        If IsError(Application.Match(i, not_use, 0)) Then

    Set ws = Worksheets(prj.VBComponents("Sheet" & i).Properties("Index").Value)
    'Set ws = ThisWorkbook.Sheets(i)

    Set bCell = Sheet11.Range("A1")

    With ws
        Set aCell = .Range("Table").Find(what:="Z-Sprd (bp)", LookIn:=xlValues, lookat:=xlWhole, _
                    MatchCase:=False, SearchFormat:=False)

    'look for the row number and column number
    colnum = ws.UsedRange.Find(what:=Sheet11.Range("A1"), lookat:=xlWhole).Column
    rownum = ws.UsedRange.Find(what:=Sheet11.Range("A1"), lookat:=xlWhole).Row

    ws.Columns(colnum).Insert Shift:=xlToRight
    '~~> Copy the entire column
    aCell.EntireColumn.Copy

    'Set the column range to work with
    Set selrange = ws.Columns(colnum)

    '~~> Insert the column here
    With ws
       .Columns(colnum).PasteSpecial xlPasteValues
       .Columns(colnum).Resize(.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "0.0"
       bCell.Copy ws.Cells(rownum, colnum)
       ws.Cells(rownum, colnum) = ws.Cells(rownum, colnum) + 7

    End With
    End With
    End If
    Next i

End Sub

代码有效，现在我只需要将列格式化为与其他列相同。我希望有人会发现它有用。欢呼声。

查找标题并将整列复制到左侧VBA

1 个答案: