4

私は、潜在的な問題の解決策を見つけるのに少し苦労しています。VBA を使用してスーパーバイザー用のマクロを作成しているので、スーパーバイザーはこのマクロに割り当てられたボタンをクリックするだけで指示に従い、必要なデータを取得できます。私が直面している問題は、マクロがデータを貼り付けるときです。ユーザーが複数の列を選択すると、空のセルを削除するのに問題があります。

Sub DataPull()
' Written by Agony
' Data Pull macro
Dim rng1 As Range
Dim rng2 As Range
Dim chc1
Dim chc2
Dim wb1 As Workbook
Dim wb2 As Workbook

'Choose file to get data
chc1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file to pull data from")
If chc1 = False Then Exit Sub

'Choose file to paste data
chc2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file to paste data to")
If chc2 = False Then Exit Sub

'Open first file and copy range
Set wb1 = Workbooks.Open(chc1)
Set rng1 = Application.InputBox("Select cells to transfer", "Selection", "Use your mouse/pointer to select the cells", Type:=8)
rng1.Copy
wb1.Close SaveChanges:=False

'Open second file and paste with specs
Set wb2 = Workbooks.Open(chc2)
Set rng2 = Range("A1")
rng2.PasteSpecial
With Selection.Interior
    .Pattern = xlNone
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With
With Selection.Font
    .Name = "Cambria"
    .Size = 12
    .TintAndShade = 0
End With

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

'Loop to delete empty cells
Dim i As Long
Dim rows As Long
Dim rng3 As Range
Set rng3 = ActiveSheet.Range("A1:Z50")
rows = rng3.rows.Count
For i = rows To 1 Step (-1)
    If WorksheetFunction.CountA(rng3.rows(i)) = 0 Then rng3.rows(i).Delete
Next

wb2.Activate
MsgBox ("Macro Complete")
End Sub

上記のとおり、範囲は現時点では暫定的なものです。ユーザーが複数の列を持つ範囲を選択した場合、空のセルを削除する機能が欲しいです。セルに使用Lenしてみましたが、それもうまくいかないようです。どんな助けでも大歓迎です。ありがとう！

4

1 に答える 1

3

ソースブックが閉じているときは.Copyandを使用できないと思います。.Paste

ワークブックを閉じると、コピーしているものはすべて失われると思います。

したがって、問題の解決策として考えられるのは、copy コマンドの直後ではなく、マクロの最後で wb1 を閉じることです。

したがってwb1.Close SaveChanges:=False、このブロックの後に移動します

...
'Open second file and paste with specs
Set wb2 = Workbooks.Open(chc2)
Set rng2 = Range("A1")
rng2.PasteSpecial
With Selection.Interior
    .Pattern = xlNone
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With
With Selection.Font
    .Name = "Cambria"
    .Size = 12
    .TintAndShade = 0
End With
wb1.Close SaveChanges:=False ' moved it here
...

削除

このサブを試して、これがあなたが望むものかどうかを確認してください. スプレッドシートで使用されている最後の列と、各列の最後の行を見つけます。各列の最後の行から繰り返し、空のセルをすべて削除して、塗りつぶされたセルを上にシフトします。

Sub DeleteAllAtOnce()
Application.ScreenUpdating = False
    Dim lastColumn As Long
    Dim lastRow As Long

    lastColumn = ActiveSheet.UsedRange.Columns.Count

    Dim i As Long, j As Long
    Dim cell As Range
    For i = lastColumn To 1 Step -1
        lastRow = Cells(rows.Count, i).End(xlUp).Row
        For j = lastRow To 1 Step -1
            Set cell = Cells(j, i)
            If IsEmpty(cell) Then cell.Delete shift:=xlUp
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub
于 2013-11-11T14:34:25.403 に答える