-1

「条件を機能させようとしましたが、結果はありません。セルが条件 (セルの色は RGB(128, 128, 128)) を満たすときはいつでも、セルをフォーマットとして貼り付ける方法が必要です (セルの色は RGB(128, 128, 128))。それ以外の場合は、値をすべて貼り付けます。今回は私の質問が受け入れられることを願っており、どんな助けも大歓迎です! DropBox リンクに添付されている私の Excel ワークブックを見つけてください >>>" ファイル

Sub CopyPasteSave()
Dim wbSource As Excel.Workbook
Dim wbTarget As Excel.Workbook
Dim nm As Name
Dim ws As Worksheet
Dim CellsToCopy() As String
Dim i As Long
Dim Path As String
Dim rcell As Range
Dim lastCol As String
Dim lastRow As String
Dim cell As Range



If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
          "New sheets will be pasted as values, named ranges removed" _
 , vbYesNo, "NewCopy") = vbNo Then
    Exit Sub
End If
Set wbSource = ActiveWorkbook
Set rcell = Sheets("EPF Daily Report").Range("I5")
Path = "D:\"
'Enter cells to copy with formulas
CellsToCopy = Split(("B11,B12"), ",")
Application.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Sheet names go inside quotes, separated by commas
On Error GoTo ErrCatcher
wbSource.Sheets(Array("InletManifold", "Separator", "Crude Strippers & Reboilers ", "Water Strippers  & Reboilers ", "Crude Storage&Export", "GSU,FLARE & GEN", "EPF Utility", "EPF Daily Report", "Choke Size")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hyperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
Set wbTarget = ActiveWorkbook
For Each ws In wbTarget.Worksheets
    With ws
           .Cells.Select

         For Each cell In Selection

        If cell.Interior.Color = Excel.XlRgbColor.rgbGrey Then


        .[A1].PasteSpecial Paste:=xlFormats  ' paste the formulas that i want to keep

        Else

          .[A1].PasteSpecial Paste:=xlValue ' all other cells paste them as values
        End If

        Application.CutCopyMode = False
        Application.DisplayAlerts = False
        .Cells.Hyperlinks.Delete
        Application.DisplayAlerts = False
        Application.Goto .Range("A1")

        Next

    End With
Next ws
With wbTarget
   ' Remove named ranges
    For Each nm In .Names
        nm.Delete
    Next nm
    ' Input box to name new file
    'NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
    ' Save it with the NewName and in the same directory as original
    .SaveAs Filename:=Path & " " & "EPF Daily Report" & " " & rcell.Value & ".xls"
    .Close SaveChanges:=True
End With


Exit_Point:
Application.ScreenUpdating = False
Application.DisplayAlerts = True
Exit Sub

ErrCatcher:
MsgBox "specified sheets do not exist within this work book"
Resume Exit_Point
End Sub
4

2 に答える 2

0

コードに関する次のコメントでは、指定されたセルの数式のみをコピーし、それらのセルが灰色でフォーマットされている場合にのみ数式をコピーすることを前提としています。

    Sub CopyPasteSave()

     . . .    

1.  CellsToCopy = Split(("B11,B12"), ",")

   <This use of split to assign array elements does not work. Better
    to go with CellsToCopy = Array("B11", "B12").>

    . . .

    For Each ws In wbTarget.Worksheets
       With ws

2.        .Cells.Copy        
          .[A1].PasteSpecial Paste:=xlValues

         <You have lost your reference to wbSource. Better written as
          wbSource.Worksheets(ws.Name).Cells.Copy and wbSource.Worksheets(ws.Name).
          [A1].PasteSpecialPaste:=xlValues. (I am assuming the reference to
          [A1] will work.)>

2.        Set acell = wbSource.workbook

         <You have declared acell as a String, but are trying to assign a 
          workbook to it. To iterate across all the cells in the source workbook, 
          you'll have to do it sheet-by-sheet.>

3.        Do While Not IsEmpty(acell)

         <Misplaced?>

4.        If acell.Interior.ColorIndex = 48 Then '-- make sure color index is correct
             For i = LBound(CellsToCopy) To UBound(CellsToCopy)
                wbSource.Worksheets(ws.Name).Range(CellsToCopy(i)).Copy
                ws.Range(CellsToCopy(i)).PasteSpecial xlPasteFormulas
             Next i
          End If

          <Would suggest that you move the Empty and color test into the For 
           ... Next loop. Also, no need to specifically reference ws, as you are
           already in With ws...End With.>
于 2013-01-02T07:53:57.983 に答える
0

「貴重な通知をありがとうチャフ。今のところ動作しています。コードを以下のように修正しましたが、ワークシートをコピーするときは少し遅いです!」

Sub CopyPasteSave()
    Dim wbSource As Excel.Workbook
    Dim wbTarget As Excel.Workbook
    Dim nm As Name
    Dim ws As Worksheet
    Dim Path As String
    Dim rcell As Range
    Dim cell As Range

    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
            "New sheets will be pasted as values, named ranges removed", _
            vbYesNo, "NewCopy") = vbNo Then
        Exit Sub
    End If
    Set wbSource = ActiveWorkbook

    Set rcell = wbSource.Worksheets("EPF Daily Report").Range("I5")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ' Copy specific sheets
    ' *SET THE SHEET NAMES TO COPY BELOW*
    ' Sheet names go inside quotes, separated by commas
    On Error GoTo ErrCatcher
    wbSource.Worksheets(Array("InletManifold", "Separator", _
        "Crude Strippers & Reboilers ", "Water Strippers  & Reboilers ", _
        "Crude Storage&Export", "GSU,FLARE & GEN", "EPF Utility", _
        "EPF Daily Report", "Choke Size")).Copy
    On Error GoTo 0
    ' Paste sheets as values
    ' Remove External Links, Hyperlinks and hard-code formulas
    ' Make sure A1 is selected on all sheets
    Set wbTarget = ActiveWorkbook
    For Each ws In wbTarget.Worksheets
        With ws
            For Each cell In .UsedRange
                If cell.Interior.Color <> RGB(192, 192, 192) Then
                    If cell.HasArray Then
                        With cell.CurrentArray
                       .Value = .Value 'clearing array
                        End With
                       Else
                       cell.Value = cell.Value
                    End If
                End If
            Next cell
            .Hyperlinks.Delete
        End With
    Next ws
    With wbTarget
        ' Remove named ranges
        For Each nm In .Names
            nm.Delete
        Next nm
        Path = "C:\"
        .SaveAs Filename:=Path & " " & "EPF Daily Report" & " " & rcell.Value & ".xls"
        .Close SaveChanges:=False
    End With

Exit_Point:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
Application.Visible = False
    Exit Sub

ErrCatcher:
    MsgBox "specified sheets do not exist within this work book"
    Resume Exit_Point
End Sub
于 2013-01-02T20:33:34.710 に答える