vba - Vbaプログラムは2回実行されません

Question

これが私の最初の質問ですので、しばらくお待ちください:)

私は経験豊富なVBAプログラマーではなく、ソフトウェアでいくつかの問題を抱えています。

いくつかのデータを貼り付けてから、いくつかの新しい列を追加するプログラムがあります。その後、いくつかのテキストを分割し、新しい列内のセル内に配置します。

プログラムは最初は完璧に動作しますが、2回目はデータが間違って貼り付けられているように見えます。見た目が異なり、一部のセルからデータを取得しているときにプログラムが失敗します。魔女は明らかに存在しません。

次のエラーが発生します：ワークシート関数クラスの平均プロパティを取得できません

あなたがいくつかの良いアイデアを持っていることを願っています。すべてのフォーマット、コンテンツなどをクリアしようとしました。

ありがとうございました。

これが私のコードです。プログラミングスタイルが悪いのでごめんなさい。ループのいくつかをよりスムーズなものに集める必要がありますが、最初にそれが機能する必要があります:)

お時間をいただきありがとうございます！

   Option Explicit

Private Sub btnExit_Click()

Application.Quit


End Sub


Private Sub btni2_Click()

Application.ScreenUpdating = False
Application.DisplayAlerts = False


Worksheets("System").Activate
Worksheets("System").Cells(1, 1).Select
ActiveCell.PasteSpecial

On Error GoTo myError:

Worksheets("System").Cells(2, 2) = "=COUNTA(A3:A10000)"
Dim laps As Integer
laps = Worksheets("System").Cells(2, 2)
'MsgBox ("Resultat er: " & laps)

' Opret nye kolloner til at seperare tekst fra I2.
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("F:F").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove


'Flyt text til nye kolloner for at splitte data op
'Split A
    Range("A3:A10000").Select
    Selection.TextToColumns Destination:=Range("A3"), DataType:=xlDelimited, _
        TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

'Split C
    Range("C3:C10000").Select
    Selection.TextToColumns Destination:=Range("C3"), DataType:=xlDelimited, _
        TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

'Split E
    Range("E3:E10000").Select
    Selection.TextToColumns Destination:=Range("E3"), DataType:=xlDelimited, _
        TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

'Split G
    Range("G3:G10000").Select
    Selection.TextToColumns Destination:=Range("G3"), DataType:=xlDelimited, _
        TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True


'check om der er data i Main arket
    Dim Check As String


    Check = Worksheets("Main").Range("B1").Value

    If Check = "" Then

        Worksheets("System").Range("A3").Copy
        Worksheets("Main").Select
        Range("B1").Select
        Selection.PasteSpecial
        Worksheets("System").Select

        Worksheets("System").Range("B3").Copy
        Worksheets("Main").Select
        Range("B2").Select
        Selection.PasteSpecial
        Worksheets("System").Select

        Worksheets("System").Range("C3").Copy
        Worksheets("Main").Select
        Range("B6").Select
        Selection.PasteSpecial
        Worksheets("System").Select

        Worksheets("System").Range("D3").Copy
        Worksheets("Main").Select
        Range("B4").Select
        Selection.PasteSpecial
        Worksheets("System").Select

        Worksheets("System").Range("E3").Copy
        Worksheets("Main").Select
        Range("B3").Select
        Selection.PasteSpecial
        Range("B7").Value = "Mads S. Christiansen"
        Worksheets("System").Select


    End If


    'definer alle de variabler der skal pastes ind i de respektive sessions
    Dim EditLaps As Integer
    Dim FastLap As Variant 'J
    Dim NoLaps As Integer 'inkl in/out brug variabel laps fra tidligere
    Dim TotalTime As Variant 'Sum af alle felter i J =sum(J3:J+laps)
    Dim TotalKm As Variant ' AM3 og AN & laps +3 trukket fra hinanden
    Dim MaxRpm As Long 'Max V3 til V & laps + 3
    Dim MaxWaterT As Double ' max O3 til O & laps + 3
    Dim AvgWaterT As Double ' avg O3 til O & laps + 3
    Dim MaxOilT As Double ' MAX Q3 til Q & laps + 3
    Dim AvgOilT As Double ' AVG
    Dim IntakeT As Double
    Dim MaxOilP As Double
    Dim MinOilP As Double
    Dim AvgOilP As Double
    Dim MaxCoolP As Double
    Dim MinCoolP As Double
    Dim AvgCoolP As Double
    Dim TotalKm1, TotalKm2 As Variant

    NoLaps = laps
    'Bruges som reference for at det passser med offset pga af første celle ref
    EditLaps = NoLaps + 2
    'Find hurtigste omgang og tildel den til FastLap
    FastLap = Application.WorksheetFunction.Min(Range(Cells(3, 10), Cells(EditLaps, 10)))
    ' Denne format virker !! Range("Z1").NumberFormat = "mm:ss.000"

    ' Total tid for session
    TotalTime = Format(Application.WorksheetFunction.Sum(Range(Cells(3, 10), Cells(EditLaps, 10))), "HH:MM:SS")

    'Total antal km for session, er dist slut minus dist start
    TotalKm1 = Range("AM3").Value
    TotalKm2 = Range("AN" & EditLaps).Value

    TotalKm = TotalKm2 - TotalKm1

    '------------------------------------------ Dette er for at convertere felte om til nummerisk formatering----------
    Dim a As Variant
    Dim b As Variant
    Dim c As Variant
    Dim d As Variant
    Dim e As Variant
    Dim f As Variant
    Dim g As Variant
    Dim h As Variant
    Dim i As Variant
    Dim j As Variant

    For Each a In Range("V1:V" & EditLaps)
    If a = "" Then GoTo nexta
    If IsNumeric(a) Then
        a.Value = a.Value * 1
        a.NumberFormat = "general"
    End If

nexta:
Next a

 For Each b In Range("N1:N" & EditLaps)
    If b = "" Then GoTo nextb
    If IsNumeric(b) Then
        b.Value = b.Value * 1
        b.NumberFormat = "general"
    End If

nextb:
Next b

For Each c In Range("O1:O" & EditLaps)
    If c = "" Then GoTo nextc
    If IsNumeric(c) Then
        c.Value = c.Value * 1
        c.NumberFormat = "general"
    End If

nextc:
Next c

For Each d In Range("K1:K" & EditLaps)
    If d = "" Then GoTo nextd
    If IsNumeric(d) Then
        d.Value = d.Value * 1
        d.NumberFormat = "general"
    End If

nextd:
Next d

For Each e In Range("L1:L" & EditLaps)
    If e = "" Then GoTo nexte
    If IsNumeric(e) Then
        e.Value = e.Value * 1
        e.NumberFormat = "general"
    End If

nexte:
Next e

For Each f In Range("Q1:Q" & EditLaps)
    If f = "" Then GoTo nextf
    If IsNumeric(f) Then
        f.Value = (f.Value * 1) / 1000
        f.NumberFormat = "general"
    End If

nextf:
Next f

For Each g In Range("P1:P" & EditLaps)
    If g = "" Then GoTo nextg
    If IsNumeric(g) Then
        g.Value = (g.Value * 1) / 1000
        g.NumberFormat = "general"
    End If

nextg:
Next g

For Each h In Range("R1:R" & EditLaps)
    If h = "" Then GoTo nexth
    If IsNumeric(h) Then
        h.Value = (h.Value * 1) / 1000
        h.NumberFormat = "general"
    End If

nexth:
Next h

For Each i In Range("T1:T" & EditLaps)
    If i = "" Then GoTo nexti
    If IsNumeric(i) Then
        i.Value = i.Value * 1
        If i.Value >= 1 Then
        i.Value = i.Value / 1000
        End If
        i.NumberFormat = "general"
    End If

nexti:
Next i

For Each j In Range("S1:S" & EditLaps)
    If j = "" Then GoTo nextj
    If IsNumeric(j) Then
        j.Value = j.Value * 1
        If j.Value >= 1 Then
        j.Value = j.Value / 1000
        End If
        j.NumberFormat = "general"
    End If

nextj:
Next j

    'Max rpm
    MaxRpm = Application.WorksheetFunction.Max(Range(Cells(3, "V"), Cells(EditLaps, "V")))

    'Max vand temp
    MaxWaterT = Application.WorksheetFunction.Max(Range(Cells(3, "N"), Cells(EditLaps, "N")))
    AvgWaterT = Application.WorksheetFunction.Average(Range(Cells(3, "O"), Cells(EditLaps, "O")))

    MaxOilT = Application.WorksheetFunction.Max(Range(Cells(3, "K"), Cells(EditLaps, "K")))
    AvgOilT = Application.WorksheetFunction.Average(Range(Cells(3, "L"), Cells(EditLaps, "L")))

    'IntakeT =

    MaxOilP = Application.WorksheetFunction.Max(Range(Cells(4, "Q"), Cells(EditLaps - 1, "Q")))
    MinOilP = Application.WorksheetFunction.Min(Range(Cells(4, "P"), Cells(EditLaps - 1, "P")))
    AvgOilP = Application.WorksheetFunction.Average(Range(Cells(4, "R"), Cells(EditLaps - 1, "R")))

    MaxCoolP = Application.WorksheetFunction.Max(Range(Cells(4, "T"), Cells(EditLaps - 1, "T")))
    MinCoolP = Application.WorksheetFunction.Min(Range(Cells(4, "S"), Cells(EditLaps - 1, "S")))
    AvgCoolP = Application.WorksheetFunction.Average(Range(Cells(4, "T"), Cells(EditLaps - 1, "T")))



    ' lav et object der indeholder det sheet som der skal bruges
    Dim Sheet As Object
    Set Sheet = Worksheets("Main")

    'Definer hvilken session der er kopieret ind
    Dim Session As String


    Session = UCase(Range("F3"))

    Select Case Session

    Case Is = " TEST"
        Set Sheet = Worksheets("Test")
    Case Is = " Q1"
        Set Sheet = Worksheets("Q1")
    Case Is = " Q2"
        Set Sheet = Worksheets("Q2")
    Case Is = " WU"
        Set Sheet = Worksheets("WU")
    Case Is = " RACE1"
        Set Sheet = Worksheets("Race1")
    Case Is = " RACE2"
        Set Sheet = Worksheets("Race2")
    End Select


    Sheet.Activate

    Range("B3").Value = FastLap
    Range("B4").Value = NoLaps
    Range("B5").Value = TotalTime
    Range("B7").Value = TotalKm
    Range("B13").Value = MaxRpm
    Range("B16").Value = MaxWaterT
    Range("B17").Value = AvgWaterT
    Range("B20").Value = MaxOilT
    Range("B21").Value = AvgOilT
    Range("B24").Value = 25
    Range("B27").Value = MaxOilP
    Range("B28").Value = MinOilP
    Range("B29").Value = AvgOilP
    Range("B32").Value = MaxCoolP
    Range("B33").Value = MinCoolP
    Range("B34").Value = AvgCoolP


    Sheet9.Activate
    Sheet9.Cells.Select
    With Cells
    .Clear
    .ClearComments
    .ClearContents
    .ClearFormats
    .ClearHyperlinks
    .ClearNotes
    .ClearOutline
    End With

    ' aktiver main siden efter endt handling af System seperation
    Worksheets("Main").Activate
    Cells(1, 1).Select
'Fjern hovedform fra billede og derefter vises Main arket.
MainForm.Hide


myError:
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        If Err Then MsgBox Err.Description, vbCritical, "Error"


End Sub

Private Sub btnView_Click()
' aktiver kun main sheet hvis der oenskes view.
Worksheets("Main").Activate
'marker celle
Cells(1, 1).Select
'gem main form sΠder kun er normalt excel view
MainForm.Hide

End Sub

Answer 1

コードが質問に追加される前に投稿された回答

新しいVBAプログラマーにとっての簡単な間違いは、アクティブなワークシートで動作するマクロを作成することです。これは、マクロを呼び出す前に別のシートを見るまではうまく機能します。

たとえば、次のように書くことができます。

Range("A1").Value = "abc"
Cells(29, "B").Font.Bold = True

上記のステートメントは、アクティブなワークシートで機能します。

With Worksheets("Master")
  .Range("A1").Value = "abc"
  .Cells(29, "B").Font.Bold = True
End With

この2番目の例では、ステートメントをワークシートマスターで操作するように明示的に記述しました。Rangeの前後にドットを追加したことに注意してくださいCells。このように書かれているので、マクロを開始したときにどのシートを見ていたかは関係ありません。

ステートメントを使用しWithてターゲットワークシートを指定しないことは、マクロの開始時にカーソルが正しい場所にある場合にのみ機能するコードを記述する一例にすぎません。説明する症状は、このタイプのエラーと一致します。

あなたのコードを見てください。それはどのような仮定をしますか？これで問題が解決しない場合は、Kevinの質問に従って、コードを投稿してください。これをする：

• 質問を編集します。
• コードを質問にコピーします。
• コードを選択し、編集ウィンドウの上にある中括弧をクリックします。これにより、各行の先頭に4つのスペースが追加され、コードとして表示されます。

質問にコードを追加した後に投稿された回答

私はあなたのコードのいくつかに取り組んできました。コンテキストがないため、正しく実行できません。どんな種類のデータを操作しているのかわかりません。

ただし、次のコメントが役立つ場合があります。言いたいことがわかったら、さらに追加します。

デバッグ中にこれらのコマンドのいずれも必要ありません。

'Application.ScreenUpdating = False
'Application.DisplayAlerts = False

あなたが何をしようとしても、これがそれを達成するための良い方法だとは思いません。実行できるステートメントにアクセスできるように、削除する必要がありました。 編集 あなたのコードのいくつかを調べてそれを理解したので、これがあなたの問題の原因であるかどうか疑問に思います。これについては、後で、あなたが何をしているのかをよりよく理解できるようにするコードに到達したときに説明します。

'Worksheets("System").Activate
'Worksheets("System").Cells(1, 1).Select
'ActiveCell.PasteSpecial

他の人にリリースしたいまで、自分のマクロにエラー処理を含めることはありません。テスト中、マクロを誤ったステートメントで停止し、ソースがわからないエラーメッセージで正常に失敗しないようにします。

'On Error GoTo myError:

簡単に見つけられるように、すべての変数をマクロの上部にグループ化することを好みます。これは必要ではなく、私の好みです。32ビットシステムでLongは、は整数値のネイティブサイズです。 Integer16ビット変数を指定し、特別な処理が必要であり、実行速度が低下します。

Dim laps As Long

With statementワークシートを切り替えてセルを選択するのではなく、使用するように以下を変更しました。切り替えと選択は遅く、非常に混乱する可能性があります。必要がない限り、どちらもしないでください。

With Worksheets("System")
  .Cells(2, 2).Value = "=COUNTA(A3:A10000)"
  laps = .Cells(2, 2).Value
End With

上記は、以前の貼り付けによってロードされた行数を判別しようとしていると思います。問題は、これが空白行の数を数えることです。空白行は絶対に不可能ですか？また、10,000は、貼り付けによってロードされる可能性があるよりも多くの行を表すと想定しています。

一番下の行を見つけるためのさまざまな手法があります。いずれもすべての状況で機能するわけではありません。最も簡単なテクニックは次のとおりです。

Dim RowLast As Long
With Worksheets("System")
  RowLast = .Cells(Rows.Count, "A").End(XlUp).Row
End With

Rows.Countお使いのバージョンのExcelの最大行数です。このVBAは、列「A」の一番下の行にカーソルを置き、Ctrl + Upをクリックすると、列「A」の最後の行に値がジャンプするのと同じです。その行の番号はLastRowに配置されます。

このコードを考えてみましょう：

  Columns("B:B").Select
  Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
  Columns("D:D").Select
  Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
  Columns("F:F").Select
  Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
  Columns("H:H").Select
  Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

上記のコードの目的は、列B、C、D、Eのそれぞれの前に空白の列を作成することです。ただし、列Bの前に列を挿入すると、列Cが列Dに移動します。左から右に挿入を実行すると言われています。右から左に実行するよりも少し速いですが、私は気にしません。ルーチンが1日に何千回も実行される場合、またはそれが本当に遅い場合は、効率について考えます。しかし、節約できるのが数ミリ秒だけだと理解しにくいと思うコードは書きません。

VBAの問題は、同じ効果を達成する方法が常にいくつかあり、ある方法が別の方法よりも優れている明確な理由がない場合が多いことです。私のバージョンのコードでは、挿入列を使用しました。私はタイミングを実行していません-したがって、どちらの方法が速いかわかりません-挿入列がより明確であることがわかります。

「Opretnyekollonertil at seperare tekst fra I2」は、なぜこれを行っているのかを示していると思います。何をどのように追加したかに注意してください。6か月または12か月後にこのコードに戻ったとき、何を、なぜ、どのように見つけるためにコードを研究する必要はありません。言われたい。Unixオペレーティングシステムは美しく文書化されていると言われていますが、必ずしもそうではありませんでした。どうやらコードのブロックが向かっていたようです：「かつては神と私だけがこのルーチンが何をするかを知っていました。今では神だけが知っています。」あなたはあなた自身のコードについてそれを言う必要はありません。私は自分のコードを書いた1、2週間後に自分のコードを見るのが好きですが、それでも多かれ少なかれそれが何をするのかを覚えています。理解するのに苦労しているのなら、もっとコメントが必要だと思います。

Dim ColCodeCrnt As Variant

With Worksheets("WRASystem")
  ' Insert a blank column before each of columns E, D, C and B.
  ' Insertions in reverse order to make code clearer since an
  ' insertion before column B moves column C.
  For Each ColCodeCrnt In Array("E", "D", "C", "B")
    .Columns(ColCodeCrnt).EntireColumn.Insert
  Next
End With

ここで、ブロックの開始について考えてみましょう。

  Range("A3:A10000").Select
  Selection.TextToColumns Destination:=Range("A3"), DataType:=xlDelimited, _
      TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
      Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
      :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

このことから、最初に貼り付けたブロックにはN行4列があると推測されます。各セルには「Value1、Value2」が含まれています。値を分割して、「値1」が列Aに残り、「値2」が新しく空になった列Bに移動するようにします。これは、列C、E、およびGに対して繰り返されます。

前に言ったように、10000はブロックのサイズに対して信じられないほど大きな行番号を表すと思います。ワークシートの実際の最後の行を取得する方法を上に示しました。すぐに、このコードを改善するために最後の行の番号を使用する方法を示します。ただし、最初に対処する必要のある問題があります。

このマクロを呼び出しますbtni2_Click()。私の推測では、ユーザーは関心のある範囲を選択し、ボタンi2をクリックします。コードはその範囲をワークシートシステムに貼り付けてから再生します。しかし、それはワークシートシステムが空であることに依存しています。新しい範囲の行数が最後の範囲より少ない場合、コードは新しい範囲と古い範囲の一部で動作します。

このコードを考えてみましょう：

Sub btni2_Click()

  Dim AddrSrc As String
  Dim WkShtSrc As String

  WkShtSrc = Selection.Worksheet.Name
  AddrSrc = Selection.Address

  Debug.Print WkShtSrc & "!" & AddrSrc

  With Worksheets("System")
    .Cells.EntireRow.Delete
    Range(WkShtSrc & "!" & AddrSrc).Copy Destination:=.Range("A1")
  End With

このコードが最初に行うことは、選択した範囲の詳細を記録することです。Debug.Print私が保存したものを確認できるように、を含めました。そうすれば、選択の詳細を失うことなく、好きなことを行うことができます。実際、私が行うのは、セルA1から始まる長方形にソース範囲をコピーする前に、ワークシートのすべての行を削除する（つまり、クリアする）ことだけです。

私は今、あなたの代わりとしてこのコードをお勧めします。注：（1）選択はありません。（2）宛先範囲の先頭にドットがあり、Withステートメントによって修飾されていることを示します。（3）ループに含めることができる範囲を作成します。TestToColumns分割されるデータについて何も知らないため、パラメータをに変更していません。

  With Worksheets("WRASystem")
    For Each ColCodeCrnt In Array("A", "C", "E", "G")
      .Range(ColCodeCrnt & "3:" & ColCodeCrnt & RowLast).TextToColumns _
              Destination:=.Range(ColCodeCrnt & "3"), DataType:=xlDelimited, _
              TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
              Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
              FieldInfo:=Array(Array(1, 1), Array(2, 1)), _
             TrailingMinusNumbers:=True
    Next
  End With

これ以上あなたのコードを見ることはありません。私はあなたに多くのことを考えさせました、そして私はあなたの問題の原因を発見したかもしれません。必要に応じて、さらに質問をして戻ってきてください。