更改现有宏以从特定列中复制公式

Question

这是我仍然是我的第一个宏，我一直在寻找像一个疯狂的人试图让它工作...而且它越来越接近！

我已将它设置为从Active工作簿中将“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 

此外，如果没有公式，它只是复制文本，以便你能做到这一点的所有单元格。