更改现有macros以从特定列复制公式
这仍然是我的第一个macros，我一直在寻找像一个疯子，试图让这个工作…而且它正在接近！
我把它设置为从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 正如你所说，我认为最好的一步是最初复制所有的公式。 接下来我要做的是定义一个数组，其中包含您需要作为值的列字母，您可以按如下所示进行操作。
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
此外，如果没有公式，它只是复制文本，所以你可以做所有的单元格。