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

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

Я установил, чтобы скопировать лист «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 

Как вы говорите, я считаю, что лучший шаг – скопировать все как формулы изначально. То, что я буду делать дальше, это определить массив, который содержит буквы столбцов, которые должны быть значениями, вы можете сделать это следующим образом.

 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 

Надеюсь, это поможет, дайте мне знать, если вам нужно больше разъяснений.

Вы можете сделать это без копирования и вставки. Например, скажем, вы хотите скопировать все формулы из 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 

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

Давайте будем гением компьютера.