Question

这是我的第一个宏观，我一直在寻找一个疯狂的男人试图让这个工作......而且它已经接近了！

我已将它设置为复制＆＃34; Pricing_Cost＆＃34;将活动工作簿中的工作表作为值添加到新工作簿中，然后再操作它。我真正需要的是修改该步骤，以便某些列复制值，其他列复制公式。我有专栏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

如果没有公式，它只会复制文本，以便您可以为所有单元格执行此操作。

更改现有宏以从特定列复制公式

2 个答案: