更改現有宏以從特定列復制公式

Question

這是我仍然是我的第一個宏，我一直在尋找一個瘋狂的人試圖讓這個工作......而且它越來越近了！

我已將其設置為將“活動工作簿”中的“Pricing_Cost”工作表復制為新工作簿作為值，然后將其操作超出該值。 我真正需要的是修改該步驟，以便某些列復制值，其他列復制公式。 我有A：X列

需要粘貼為值的列= A，E，F，H，I，J，K，L，M，N，T，U，V，W，X

需要粘貼為公式的列= B，C，D，G，O，P，Q，R，S

這是在CopyRemoveFormSave子中

我猜也許我應該將整個事情復制為公式然后剪切並粘貼為需要轉換為值的列的值？ 不確定如何使用我在這里的代碼...

    Public strFile As String
Sub RunAll()
    Call load_csv
    Call CopyRemoveFormAndSave
    Call Splitbook
End Sub
Sub load_csv()

    Dim fStr As String

With Application.FileDialog(msoFileDialogFilePicker)
    .Show
    If .SelectedItems.Count = 0 Then
        MsgBox "Cancel Selected"
        Exit Sub
    End If
    'fStr is the file path and name of the file you selected.
    fStr = .SelectedItems(1)
End With

Sheets("Product_Weekly").UsedRange.ClearContents

With ThisWorkbook.Sheets("Product_Weekly").QueryTables.Add(Connection:= _
"TEXT;" & fStr, Destination:=ThisWorkbook.Sheets("Product_Weekly").Range("$A$1"))
    .Name = "CAPTURE"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = True
    .TextFileSemicolonDelimiter = True
    .TextFileCommaDelimiter = False
    .TextFileSpaceDelimiter = False
    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False

End With
End Sub


Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH As Long = 260

'~~> Function to get user's temp directoy
Function TempPath() As String
    TempPath = String$(MAX_PATH, Chr$(0))
    GetTempPath MAX_PATH, TempPath
    TempPath = Replace(TempPath, Chr$(0), "")
End Function


Sub CopyRemoveFormAndSave()

    Dim wb As Workbook, wbNew As Workbook
    Dim ws As Worksheet
    Dim wsName As String, NewName As String
'    Dim shp As Shape

Set wb = ThisWorkbook

wsName = ActiveSheet.Name

NewName = wsName & ".xlsm"

wb.SaveCopyAs TempPath & NewName

Set wbNew = Workbooks.Open(TempPath & NewName)

wbNew.Sheets(wsName).UsedRange.Value = wbNew.Sheets(wsName).UsedRange.Value

Application.DisplayAlerts = False
For Each ws In wbNew.Worksheets
    If ws.Name <> wsName Then ws.Delete
Next ws
Application.DisplayAlerts = True

'    For Each shp In wbNew.Sheets(wsName).Shapes
'        If shp.Type = 8 Then shp.Delete
'    Next

'
'~~> Do a save as for the new workbook if required.
'
'End Sub

Columns("W:W").Replace "2", "KevinClark", xlWhole
Columns("W:W").Replace "9", "PaulG", xlWhole
Columns("W:W").Replace "O", "KevinClark", xlWhole
Columns("W:W").Replace "I", "KevinClark", xlWhole
Columns("W:W").Replace "4", "PaulG", xlWhole
Columns("W:W").Replace "8", "KevinClark", xlWhole
Columns("W:W").Replace "7", "KevinClark", xlWhole


'Sub SplitData()
Const NameCol = "W"
Const HeaderRow = 3
Const FirstRow = 4
Dim SrcSheet As Worksheet
Dim TrgSheet As Worksheet
Dim SrcRow As Long
Dim LastRow As Long
Dim TrgRow As Long
Dim Buyer As String
Application.ScreenUpdating = False
Set SrcSheet = ActiveSheet
LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
    Buyer = SrcSheet.Cells(SrcRow, NameCol).Value
    Set TrgSheet = Nothing
    On Error Resume Next
    Set TrgSheet = Worksheets(Buyer)
    On Error GoTo 0
    If TrgSheet Is Nothing Then
        Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        TrgSheet.Name = Buyer
'            SrcSheet.Range(HeaderRow).Copy Destination:=TrgSheet.Range(HeaderRow)
        SrcSheet.Range("A1:W3").Copy Destination:=TrgSheet.Range("A1:W3")
    End If
    TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
    SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
Next SrcRow
Application.ScreenUpdating = True

Dim sht As Worksheet

''AutoFit One Column
'    ThisWorkbook.Worksheets("Sheet1").Columns("O:O").EntireColumn.AutoFit
'
''AutoFit Multiple Columns
'    ThisWorkbook.Worksheets("Sheet1").Range("I:I,L:L").EntireColumn.AutoFit 'Columns I & L
'    ThisWorkbook.Worksheets("Sheet1").Range("I:L").EntireColumn.AutoFit 'Columns I to L
'
''AutoFit All Columns on Worksheet
'    ThisWorkbook.Worksheets("Sheet1").Cells.EntireColumn.AutoFit

'AutoFit Every Worksheet Column in a Workbook
For Each sht In wbNew.Worksheets
    sht.Cells.EntireColumn.AutoFit
Next sht


End Sub

Sub Splitbook()
'Updateby20140612
Dim xPath As String
xPath = "C:\Users\Jimbo.JAMESP-ACERLT\Documents\For Gary\Output"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
For Each xWs In ActiveWorkbook.Sheets
    If xWs.Name <> "Pricing Cost" Then
    xWs.Copy
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
    End If
  Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Answer 1

正如你所說，我認為最好的步驟是最初將所有復制為公式。 接下來我要做的是定義一個包含你需要成為值的列字母的數組，你可以這樣做。

ValArr = Array("A","E","F","H","I","J","K","L","M","N","T","U","V","W","X")

然后，您可以遍歷此數組並將每列轉換為值。

For x = Lbound(ValArr) To Ubound(ValArr)
    'Paste values in column ValArr(x)
Next

我希望這有幫助，如果您需要進一步澄清，請告訴我。

Answer 2

你可以不經任何復制和粘貼。 例如，假設您要將所有公式從Sheet1復制到Sheet2，您可以執行以下操作：

for i = 1 to lastRow
    for j in 1 to lastCol
        Sheets("Sheet2").cells(i,j).formula = Sheets("Sheet1").cells(i,j).formula
    next j
next i

此外，如果沒有公式，它只復制文本，以便您可以為所有單元格執行此操作。