既存のマクロを変更して特定の列から数式をコピーする

Question

これは私の最初のマクロです。私はこれを動作させようとしている狂った人のように検索しています。

"Pricing_Cost"シートをアクティブブックから値として新しいブックにコピーし、それを超えて操作するように設定しました。私が本当に必要とするのは、特定の列が値をコピーし、他のものが式をコピーするようにそのステップを変更することです。私は、列を有する：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

コピーと貼り付けを一切せずに実行できます。たとえば、あなたが、あなたがこのような何かを行うことができますSheet2のためにシート1からのすべての数式をコピーしたいとしましょう：

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 

また、あなたはすべてのセルのためにそれを行うことができますので、何の公式それだけでコピーしたテキストはありません場合。