0

特定の列に移動し、その列に「拒否」の値を含むすべての行を新しい Excel ファイル/ワークブックにコピーするスクリプトを作成しようとしています。

毎回失敗する実際の貼り付けコマンドを除いて、すべてがうまく機能しているようです。

コード：

サブボタン()

  Dim x As String
  Dim found As Boolean
  strFileFullName = ThisWorkbook.FullName
  strFileFullName = Replace(strFileFullName, ".xlsm", "")
  strFileFullName = strFileFullName + "_rejected.xlsx"
 ' MsgBox strFileFullName
  Set oExcel = CreateObject("Excel.Application")
  Set obook = oExcel.Workbooks.Add(1)
  Set oSheet = obook.Worksheets(1)
  oSheet.Name = "Results"

  ' Select first line of data.
  Range("E2").Select
  ' Set search variable value.
  x = "rejected"
  ' Set Boolean variable "found" to false.
  found = False
  ' Set Do loop to stop at empty cell.
  Do Until IsEmpty(ActiveCell)
     ' Check active cell for search value.
     If ActiveCell.Value = "" Then
     Exit Do
     End If
     If ActiveCell.Value = x Then
        found = True

        rowToCopy = ActiveCell.Row
        ActiveSheet.Rows(ActiveCell.Row).Select
        Selection.Copy

        oSheet.Range("A1").Select
        lastrow = oSheet.Cells(Rows.Count, "B").End(xlUp).Row
    '   oSheet.Rows(1).Select.PasteSpcial

     End If
     ' Step down 1 row from present location.
     ActiveCell.Offset(1, 0).Select

      Loop
   ' Check for found.
      If found = True Then
         MsgBox "Value found in cell " & ActiveCell.Address
      Else
         MsgBox "Value not found"
      End If
      obook.SaveAs strFileFullName
      obook.Close
End Sub

貼り付け機能で失敗し続ける理由は何ですか?

ありがとう！

4

2 に答える 2

2

これを試してみてください。選択は関係ありません。

 Sub AddWB()
    Dim nwBk As Workbook, WB As Workbook, Swb As String
    Dim Rws As Long, Rng As Range, c As Range, sh As Worksheet

    Set WB = ThisWorkbook
    Set sh = WB.Worksheets("Sheet1")

    Rws = sh.Cells(Rows.Count, "E").End(xlUp).Row
    Set Rng = Range(sh.Cells(2, 5), sh.Cells(Rws, 5))

    Set nwBk = Workbooks.Add(1)
    Swb = WB.Path & "\" & Mid(WB.Name, 1, Len(WB.Name) - 5) & ".xlsx"
    MsgBox Swb

    For Each c In Rng.Cells
        If c = "x" Then c.EntireRow.Copy nwBk.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    Next c

    nwBk.SaveAs Filename:=Swb

End Sub

XLorate.com

于 2012-12-08T15:22:36.083 に答える
1

スペルPasteSpecialが間違っているため、コマンドが失敗する可能性があります。いずれにせよ、行数が多い場合は、それらをループするよりも高速な方法を検討する必要があります。

これは、AutoFilter を使用して、条件を満たすすべての行を 1 回のパスでコピーします。また、ヘッダー行もコピーします。それが望ましくない場合は、コピー後に新しいワークシートの行 1 を削除できます。

Sub CopyStuff()
Dim SearchString As String
Dim Found As Boolean
Dim wsSource As Excel.Worksheet
Dim wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet
Dim LastRow As Long

Set wsSource = ActiveSheet
SearchString = "rejected"
With wsSource
    Found = Application.WorksheetFunction.CountIf(.Range("E:E"), SearchString) > 0
    If Not Found Then
        MsgBox SearchString & " not found"
        Exit Sub
    End If
    Set wbTarget = Workbooks.Add(1)
    Set wsTarget = wbTarget.Worksheets(1)
    wsTarget.Name = "Results"
    .Range("E:E").AutoFilter
    LastRow = .Range("E" & .Rows.Count).End(xlUp).Row
    .Range("E:E").AutoFilter field:=1, Criteria1:=SearchString
    .Range("E1:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            Destination:=wsTarget.Range("A1")
End With
wbTarget.SaveAs Replace(ThisWorkbook.FullName, ".xlsm", "_rejected.xlsx")
wbTarget.Close
End Sub

あなたのコードを使用して新しい Excel インスタンスを作成しませんでした。ここでそれが必要な理由がわかりませんでした。問題が発生する可能性があります。(たとえば、元のコードではインスタンスを kill しません。)

于 2012-12-08T16:54:05.737 に答える