0

新しいワークブックがコピーされていないときに選択している範囲がなぜわからないのですか。ワークブック シートが空白で、その理由がわかりません。

Sub NB()
    Dim X
    Dim copyRange
    Dim lngCnt As Long
    Dim strDT As String
    Dim strNewBook As String
    Dim objWS As Object
    Dim WB As Workbook
    Dim bNewBook As Boolean
    Dim topRow As Integer

    topRow = -1

    Set objWS = CreateObject("WScript.Shell")
    strDT = objWS.SpecialFolders("Desktop") & "\Book1"
    If Len(Dir(strDT, vbDirectory)) = 0 Then
        MsgBox "No such directory", vbCritical
        Exit Sub
    End If
    X = Range([f1], Cells(Rows.Count, "f").End(xlUp)).Value2
    For lngCnt = 1 To UBound(X, 1)
        If Len(X(lngCnt, 1)) > 0 Then
            If (topRow = -1) Then
                topRow = lngCnt
            Else
                If Not bNewBook Then
                    'make a single sheet workbook for first value
                    Set WB = Workbooks.Add(1)
                    copyRange = Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Value2

                    'find a way to copy copyRange into WB
                    Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Select
                    Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Copy
                    Range("A1").PasteSpecial


                    WB.SaveAs strDT & "\" & X(topRow, 1) & ".xls"
                    strNewBook = WB.FullName
                    WB.Close
                    bNewBook = True
                Else
                    Set WB = Workbooks.Add(1)
                    copyRange = Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Value2

                    'find a way to copy copyRange into WB
                    Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Select
                    Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Copy
                    Range("A1").PasteSpecial
                    WB.SaveAs strDT & "\" & X(topRow, 1) & ".xls"
                    WB.Close

                End If
                topRow = lngCnt
            End If
        End If
    Next
4

3 に答える 3

2 
Set WB = Workbooks.Add(1)

新しいワークブックを作成するとアクティブになるため、この新しいブックで範囲の参照が発生し、空のセルがコピーされます。

現在のワークブックへの参照が必要です

Dim wbCurrent As Workbook

Set wbCurrent = ThisWorkbook    'or ActiveWorkbook

対応するワークシートへの参照も取得してから、すべてを開始するRangeかCells、正しいワークシート オブジェクト変数への参照を使用します。

Dim wbCurrent As Workbook
Dim wsNew As Worksheet
Dim wsCurrent As Worksheet

Set wbCurrent = ThisWorkbook
Set wsCurrent = wbCurrent.Worksheets("Whatever Name")

Set WB = Workbooks.Add(1)
Set wsNew = WB.Worksheets(1)

さらに一歩進んで、(異なるワークシートの) 範囲を参照するオブジェクト変数を作成することもできます。やり過ぎに思えるかもしれませんが、使用しているワークブック (ワークシートなど) を明確に区別する必要があります。これにより、コードを長期的に追跡しやすくなります。

于 2013-07-18T19:39:56.317 に答える
0 
Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Select
Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Copy
Range("A1").PasteSpecial

新しいブックから空のデータを選択して、同じ空のブックにコピーしています

于 2013-07-18T19:54:35.667 に答える
0

アクティブなワークシートを設定するだけの問題ではないことがわかりました。ソース シートがアクティブでなくなった場合、「コピー」メソッドの範囲プロパティは機能しません。これを機能させるには、コピーと置換を使用せずにコード内の値を単純にコピーする必要がありました。

元のコードがわかりにくかったので、少し手を加えました。これが私が最終的に得たものです。これにより、F のキャプションに基づいてスプレッドシートが細分化され、G ～ M のデータが出力列 A ～ G にコピーされます。

Sub NB()
    Dim strDT As String
    Dim WB As Workbook
    Dim Ranges(10) As Range
    Dim Height(10) As Integer
    Dim Names(10) As String
    Dim row As Long
    Dim maxRow As Long
    Dim top As Long
    Dim bottom As Long
    Dim iData As Integer
    Dim iBook As Long


    Set objWS = CreateObject("WScript.Shell")
    strDT = objWS.SpecialFolders("Desktop") & "\Book1"
    If Len(Dir(strDT, vbDirectory)) = 0 Then
        MsgBox "No such directory", vbCritical
        Exit Sub
    End If

    iData = 0
    maxRow = Range("G" & 65536).End(xlUp).row
    If (maxRow < 2) Then
      MsgBox ("No Data was in the G column")
      Exit Sub
    End If

            ' The first loop stores the source ranges
    For row = 1 To maxRow
        If (Not IsEmpty(Range("F" & row))) Then
          If (iData > 0) Then
            Set Ranges(iData) = Range("G" & top & ":" & "M" & bottom)
            Height(iData) = bottom - top
          End If
          iData = iData + 1
          top = row + 1
          bottom = row + 1
          Names(iData) = Range("F" & row).Value2
        Else
          bottom = row + 1
        End If
    Next
    Set Ranges(iData) = Range("G" & top & ":" & "M" & bottom)
    Height(iData) = bottom - top

            ' The second loop copies the values to the output ranges.
    For iBook = 1 To iData
        'make a single sheet workbook for first value
        Set WB = Workbooks.Add(1)
        Range("A1:G" & Height(iBook)).Value = Ranges(iBook).Value2
        WB.SaveAs (strDT & "\" & Names(iBook) & ".xls")
        WB.Close
    Next
End Sub

Function IsEmpty(ByVal copyRange As Range)
   IsEmpty = (Application.CountA(copyRange) = 0)
End Function
于 2013-07-18T20:21:23.507 に答える