更改現有宏以從特定列中複製公式

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 

此外，如果沒有公式，它只是複製文本，以便你能做到這一點的所有單元格。