Измените существующий макрос, чтобы скопировать формулы из определенных столбцов

Question

Это мой еще мой первый макрос, я искал, как безумный человек, пытающийся заставить его работать ... и он приближается!

У меня есть он, чтобы скопировать лист «Pricing_Cost» из Активной книги в новую книгу как значения, а затем управлять ею за ее пределами. Мне действительно нужно изменить этот шаг, чтобы некоторые столбцы копировали значения, другие копировали формулы. У меня есть столбцы А: X

Столбцы, требующие, чтобы быть вставлены в качестве значения = А, Е, F, H, I, J, K, L, M, N, T, U, V, W, X

Столбцы, требующие, чтобы вставить в формулу = в, с, 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

Вы можете сделать это без копирования и вставки. Например, скажем, вы хотите, чтобы скопировать все формулы из Лист1 на Лист2 вы можете сделать что-то вроде этого:

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 

Кроме того, если нет никакой формулы она просто копирует текст, так что вы можете сделать это для всех ячеек.