Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


7250 / 76732 ←次へ | 前へ→

【75071】vbaのコード解説
質問  爽茶  - 13/12/8(日) 22:57 -

引用なし
パスワード
   このような質問はよくないと考えます。

現在、一からインターネットで検索しながら

調べているのですが、難しすぎます(泣き)

もし、知っているコードがありましたら、その部分だけでも解説いただけないでしょうか?

よろしくお願いいたします。

Private Sub Workbook_BeforeClose() 'ワークブックを閉じる前の処理

Application.DisplayAlerts = False '下記でデータを削除する際に確認メッセージを省略する。
On Error Resume Next     'エラーが発生するとエラーの発生した次の行から処理を続行します。
Sheets("Form").Visible = True
Sheets("Form").Delete
Application.Calculation = xlAutomatic 'エクセルの自動計算

End Sub

Private Sub Workbook_Open()  'ワークブックを開くときの処理

ActiveWindow.Caption = ActiveSheet.Name
Application.DisplayStatusBar = True 'ステータスバーにメッセージを表示
ActiveWindow.DisplayHorizontalScrollBar = True
Application.StatusBar = "e-mail: " 'メッセージ内容

End Sub

Private Sub Workbook_SheetActivate()

'B2 印刷の有効桁数 F2 フォーカス行 P2 ステップ数 AA2 改行

On Error Resume Next     'エラーが発生するとエラーの発生した次の行から処理を続行します。

  If Left$(ActiveSheet.Name, 4) = "Form" Then
      Sheets("印刷Data").ShowAllData

    If Len([S2]) = 0 Or Len([V2]) = 0 Or [P2] > 1 Then 'S2,V2の文字列が0かP2の文字列が1以上の場合
    
    Else
     Sheets("印刷Data").[A1].AutoFilter [Y1], [V2]


    End If

  End If

On Error GoTo 0


If ActiveSheet.Name = "印刷Data" Then
  ActiveSheet.Rows(Sheets(ActiveWindow.Caption).[F2]).Select
  Exit Sub
End If

ActiveWindow.Caption = ActiveSheet.Name

End Sub


Private Sub Workbook_SheetBeforeRightClick(ByVal Target As Range)

If ActiveSheet.Name <> "Data" Then Exit Sub
If Len(Target) = 0 Then Exit Sub

[2:65536].Sort Target

End Sub

Public Sub FmChange(ByVal Target As Range)

If Left$(ActiveSheet.Name, 4) <> "Form" Then Exit Sub
  If Target.Row = 1 Then
    Application.EnableEvents = False
    Application.Undo
    Application.EnableEvents = True
    Exit Sub

  End If

If Target.Count > 1 Then Exit Sub


If Target.Column = 1 Then

Application.EnableEvents = False
Target = ""
Target.Select
MsgBox "A列への入力はできません" & Space(20), vbExclamation, ""
Application.EnableEvents = True

Exit Sub

End If


Select Case Target

  Case [AA2]
  
  ActiveSheet.ResetAllPageBreaks
  
  If ([AA2] < 5) Or ([AA2] > [B2] + 3) Then
  
  Application.EnableEvents = False
  [AA2] = 0
  Application.EnableEvents = True
  
  Exit Sub
  
  End If
  
Application.ScreenUpdating = False
ActiveWindow.SelectedSheets.HPageBreaks.Add Rows([AA2].Value)
Application.ScreenUpdating = True
  
  Exit Sub
  
  
  Case [B2]
    ActiveSheet.PageSetup.PrintArea = "$4:$" & [B2] + 3

  Case [S2]

      If [P2] > 1 Then
        [S1].Select
        Exit Sub
      End If


  [V2:X2] = ""
  If Len([S2]) = 0 Then Exit Sub
  [V2].Activate
  SendKeys "%{Down}"

  Case [V2]

Application.ScreenUpdating = False

      If [P2] > 1 Then

      [S1].Select
         Exit Sub
      End If

    Application.EnableEvents = False

    On Error Resume Next
    Sheets("印刷Data").ShowAllData

    Sheets("印刷Data").[A1].AutoFilter [Y1], [V2]
    On Error GoTo 0
    Application.EnableEvents = True


Dim L As Long
On Error Resume Next
L = Application.Match([V2], Sheets("印刷Data").Columns([Y1]), 0)
If Err Then [S1].Select: Exit Sub
[F2] = L

End Select

End Sub

Public Sub FmSelectionChange(ByVal Target As Range)

'If Flg() <> 7 Then Exit Sub

If Left$(ActiveSheet.Name, 4) <> "Form" Then Exit Sub

Dim L As Long, LL As Long

On Error Resume Next
L = [F2]
If Err Then Exit Sub


  Select Case Target.Address

    Case [J2].Address
      Application.ScreenUpdating = False

LblMins:
      L = L - [P2]
      If L < 2 Then
        L = 1
      ElseIf Sheets("印刷Data").Rows(L).RowHeight = 0 Then
        GoTo LblMins
      End If

      [F2] = L
      [K2].Activate

    Case [L2].Address

      Application.ScreenUpdating = False
On Error Resume Next
      LL = Sheets("印刷Data").Cells.SpecialCells(xlCellTypeConstants).CurrentRegion.Rows.Count
If Err Then LL = 0
On Error GoTo 0


LblPlus:
      L = L + [P2]

      If L > LL Then
        L = 1

      ElseIf Sheets("印刷Data").Rows(L).RowHeight = 0 Then
        GoTo LblPlus

      End If

      [F2] = L
      [K2].Activate


    Case [S2:U2].Address, [V2:X2].Address
      If [P2] > 1 Then
MsgBox "ステップ2以上のシートではフィルタは無効です" & Space(20), , ""
        [S1].Select
         Exit Sub

      End If

      SendKeys "%{Down}"

    Case [S1].Address
      On Error Resume Next
      Sheets("印刷Data").ShowAllData
      Application.EnableEvents = False
      [S2,V2] = ""
      Application.EnableEvents = True

      On Error GoTo 0


  Case [B2].Address
    ActiveSheet.PageSetup.PrintArea = "$4:$" & [B2] + 3

    Case [H2].Address
      [F2] = 2

    Case [H3].Address
      [F2] = Sheets("印刷Data").Cells.SpecialCells(xlCellTypeConstants).CurrentRegion.Rows.Count

    Case [I1].Address
      If [P2] = 1 Then [U3].Activate

    Case [V3].Address
      [K2].Activate
  
    Case [J1].Address
       Application.Dialogs(xlDialogPrint).Show
      
       'ActiveWindow.SelectedSheets.PrintOut
       
       
    Case [L1].Address

      ActiveWindow.SelectedSheets.PrintPreview
      [K2].Activate

    Case [L3].Address
      Call RenPre

    Case Else

  End Select

End Sub


Private Sub RenPre()

Application.Calculation = xlManual

If [Y1] = 0 Or [P2] <> 1 Then

      On Error Resume Next
      Sheets("印刷Data").ShowAllData

      On Error GoTo LblErr

ElseIf Application.CountIf(Sheets("印刷Data").Range(Chr(64 + [Y1]) & ":" & Chr(64 + [Y1])), "=" & [V2]) = 1 Then
      ActiveWindow.SelectedSheets.PrintPreview
      Exit Sub
End If

Application.ScreenUpdating = False
[K2].Activate
Dim L As Long, LL As Long, LLL As Long, S As String
LL = Sheets("印刷Data").Cells.SpecialCells(xlCellTypeConstants).CurrentRegion.Rows.Count
LLL = 0
Application.DisplayAlerts = False


Dim LStp As Long, LRws As Long

LStp = [P2]
LRws = [B2]


For L = 2 To LL Step LStp
  If Sheets("印刷Data").Rows(L).RowHeight > 0 Then
    LLL = LLL + 1

  End If
Next


If LLL < 1 Then GoTo LblErr
If LLL * [B2] > 65500 Then GoTo LblErr

If LLL > 301 Then
If MsgBox("データ件数が300件を超えます。多少時間がかかります。" & Space(20) & vbCrLf & _
      "処理を継続しますか?", vbDefaultButton2 + vbYesNo + vbQuestion, "") = vbNo Then Exit Sub
End If


On Error Resume Next
Sheets("Form").Visible = True
Sheets("Form").Delete
On Error GoTo LblErr

Application.EnableEvents = False
ActiveSheet.Copy ActiveSheet

With Rows("4:" & 3 + LRws)
  .Replace "フォーカス", "Value(A:A)"

On Error Resume Next
  .AutoFill Rows("4:" & 3 + LRws * LLL), xlFillCopy
On Error GoTo 0
End With


ActiveWindow.SelectedSheets.HPageBreaks.Add Rows(LRws + 4)

LLL = 0


If LStp = 1 Then

    For L = 2 To LL Step LStp
      If Sheets("印刷Data").Rows(L).RowHeight > 0 Then

      If [AA2] <> 0 Then ActiveWindow.SelectedSheets.HPageBreaks.Add Rows(LLL * LRws + [AA2])
      
      LLL = LLL + 1
      Range("A" & (LLL - 1) * LRws + 4 & ":A" & LLL * LRws + 4) = L
      
      
      ActiveWindow.SelectedSheets.HPageBreaks.Add Rows(LLL * LRws + 4)

      End If
    Next
Else

      For L = 2 To LL Step LStp
        If Sheets("印刷Data").Rows(L).RowHeight > 0 Then

        If [AA2] <> 0 Then ActiveWindow.SelectedSheets.HPageBreaks.Add Rows(LLL * LRws + [AA2])
        LLL = LLL + 1
        Range("A" & (LLL - 1) * LRws + 4 & ":A" & LLL * LRws + 4) = (LLL - 1) * LStp + 2
        ActiveWindow.SelectedSheets.HPageBreaks.Add Rows(LLL * LRws + 4)

        End If
      Next

End If


Application.Calculation = xlAutomatic
With Cells
  .Copy
  .PasteSpecial xlValues
  Application.CutCopyMode = False
End With


[A:A].ClearContents

ActiveSheet.PageSetup.PrintArea = "4:" & 3 + LRws * LLL

[A1].Select

  ActiveWindow.FreezePanes = False
  [1:3].Delete

  ActiveWindow.View = xlPageBreakPreview
  ActiveWindow.Zoom = 75


ActiveWindow.SelectedSheets.PrintPreview

ActiveSheet.Name = "Form"


Sheets("Form").Visible = xlSheetVeryHidden

Application.EnableEvents = True


Exit Sub

LblErr:

Application.Calculation = xlAutomatic
Application.EnableEvents = True


End Sub
274 hits

【75071】vbaのコード解説 爽茶 13/12/8(日) 22:57 質問
【75073】Re:vbaのコード解説 γ 13/12/9(月) 7:54 発言

7250 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free