| |
このような質問はよくないと考えます。
現在、一からインターネットで検索しながら
調べているのですが、難しすぎます（泣き）
もし、知っているコードがありましたら、その部分だけでも解説いただけないでしょうか？
よろしくお願いいたします。
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
|
|
爽茶
- 13/12/8(日) 22:57 -
