オンライン講座 質問と回答

無料・有料のオンライン講座で 寄せられたメッセージの一部を紹介致します。

12>

[9073]発展編1 フォローメールセミナー 第18回

2017-10-17 22:42:19 浦山大さんからの投稿です。

とりあえずどんどん進めています。
今回のお話はとっても参考になりました。
私はもう、口をぽかんと開けて「え…」という状態で10秒位思考停止してました。

改行するマクロは、そのまま実務に使えそうです。
報告書の一部で、ピボットテーブルから持ってきたアンケートのコメントを表にする作業があります。凄い時間かかっていました…。

・個人用マクロブックに少しずつネタを増やしていく
・最適化の視点を持って仕事のファイルを見る

を気にしながら作業していきたいと思います。

7つの習慣みたいですね。
「私は5時間で木を切れと言われたら最初の1時間は斧を研ぐ」
のような文言が第7の習慣にあったような気がします(ちょっと記憶が曖昧です)。

↑使う道具(武器?)を最適な状態にして、
必要な力を軽減させ、全体にかかる時間も減少させるような考え方と認識しました(人間と捉えると運動や精神の修養等で全体のパフォーマンスを上げることと共通のような)。

やっぱり奥が深いですね!
最適化という言葉について、意識させられた1日でした。

[ 続きを読む ]  返信件数:3件  [ 動画を見る] 

[9054]発展編1 フォローメールセミナー 第1回

2017-10-15 11:03:03 浦山大さんからの投稿です。

おはようございます。
ずっと溜まり続けているこのフォローアップ。
今日から取り掛かり始めます!

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[9029]発展編1 フォローメールセミナー 第11回

2017-10-10 13:40:18 受講生さんからの投稿です。

小川先生、いつもお世話になっております。

【動画9】のフィードバック(コメント:9020)を踏まえ、
追加要件も実装しました。
印刷範囲をクリアするコード(.PrintArea = "")が必要だと
わかるまで時間がかかりました(汗)
添削の程、よろしくお願い致します。

Option Explicit
Dim wOg As Worksheet    '原本シート(main)の変数
Dim wDa As Worksheet    'データシート(main1)の変数
Dim cDaMxRow As Long    'データシート(main1)の最終行を示す変数
Dim cMkRow As Long      '新規シートの行を指定する変数
Dim Skey As String      'データシートの並び替えを指定する変数
    
Public Sub Homework()
    Set wOg = Worksheets("main1")
    Set wDa = Worksheets("main")
    cDaMxRow = wDa.Range("B" & Rows.Count).End(xlUp).Row
    
    DelDenpyou
    BangouFuri
    
    Skey = "B1"
    Narabikae

    CreateDenpyou

    Skey = "A1"
    Narabikae

    DeleteBangou
End Sub

Public Sub DelDenpyou()
    Dim Wsh As Worksheet
    Application.DisplayAlerts = False
    For Each Wsh In Worksheets
        With Wsh
            If .Name <> "main" And .Name <> "main1" Then  '←if文に変更
                .delete
            End If
        End With
    Next Wsh
    Application.DisplayAlerts = True
    PrintSet '[★]追加要件
End Sub

Sub PrintSet() '[★]追加要件
    If wOg.Name = "main" Then
        With wOg.PageSetup
            .LeftHeader = "&A"
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = ""
            .RightFooter = "[作成日]&D"
        End With
    Else
        With ActiveSheet.PageSetup
            .PrintArea = ""
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
    End If
End Sub

Public Sub BangouFuri()
    Dim cNt As Long
    With wDa.Range("A1")
        .Offset(0, 0).Value = "No."
        For cNt = 1 To 3
            .Offset(cNt, 0).Value = cNt
        Next cNt
    End With
    wDa.Range("A2:A4").AutoFill Destination:=wDa.Range("A2:A" & cDaMxRow)
End Sub

Public Sub CreateDenpyou()
    Dim wMk As Worksheet
    Dim cDaRow As Long
    Dim sClnt As String
    Dim dTda As Date
    For cDaRow = 2 To cDaMxRow
        If sClnt <> wDa.Range("B" & cDaRow).Value Then
            If cDaRow > 2 Then
                Keisen
                PrintSet '[★]追加要件
            End If
            wOg.Copy after:=Worksheets(Worksheets.Count)
            sClnt = wDa.Range("B" & cDaRow).Value
            Set wMk = ActiveSheet
            wMk.Name = sClnt
            cMkRow = 16
        End If
        dTda = wDa.Range("C" & cMkRow).Value
        With wMk
            .Range("B" & cMkRow).Value = Mid(Year(dTda), 3)
            .Range("C" & cMkRow).Value = Month(dTda)
            .Range("D" & cMkRow).Value = Day(dTda)
            .Range("E" & cMkRow).Value = wDa.Range("D" & cMkRow).Value
            .Range("F" & cMkRow).Value = wDa.Range("E" & cMkRow).Value
            .Range("H" & cMkRow).Value = wDa.Range("F" & cMkRow).Value
            If wDa.Range("G" & cMkRow).Value > 0 Then
                .Range("I" & cMkRow).Value = wDa.Range("G" & cMkRow).Value
            Else
                .Range("J" & cMkRow).Value = wDa.Range("G" & cMkRow).Value
            End If
            .Range("K" & cMkRow).Value = WorksheetFunction.Sum(.Range("I16:J" & cMkRow))
        End With
        cMkRow = cMkRow + 1
    Next cDaRow
    Keisen
End Sub

Public Sub Keisen()
    With Range("B16:K" & cMkRow)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
    End With
End Sub

Public Sub Narabikae()
    With wDa
        With .Sort
            With .SortFields
                .Clear
                .Add Key:=wDa.Range(Skey), Order:=xlAscending
            End With
            .SetRange wDa.Range("A1:G" & cDaMxRow)
            .Header = xlYes
            .Apply
        End With
    End With
End Sub

Public Sub DeleteBangou()
    With wDa
        .Activate '←ここに記載し、1回のみの処理に変更
        .Range("A1").Activate
        .Range("A1").EntireColumn.ClearContents
    End With
End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[9014]発展編1 フォローメールセミナー 第9回

2017-10-08 09:38:21 受講生さんからの投稿です。

小川先生、いつもお世話になっております。

宿題を投稿します。
罫線に関しては、自動記録のコードを基にネットの情報も参考にテストを繰り返して
不要と思われるコードを削除して仕上げました。
他の方の投稿と先生のコメント、勉強になります。

添削の程、よろしくお願い致します。

Option Explicit
    Dim WOg As Worksheet    '原本シート(main)の変数
    Dim WDa As Worksheet    'データシート(main1)の変数
    Dim WMk As Worksheet    '新規シートの変数
    Dim Ws As Worksheet     '全てのシートを示す変数
    Dim CDaRow As Long      '原本シート(main)の行を示す変数
    Dim CDaMxRow As Long    '原本シート(main)の最終行を示す変数
    Dim CMkRow As Long      '新規シートの行を指定する変数
    Dim SKey As String      'データシートの並び替えを指定する変数
    Dim St As String        'データシートの取引記録に登場する取引先を示す変数
    Dim Dtda As Date        'データシートの日付を示す変数
    
Public Sub Homework()
    Set WOg = Worksheets("main1")
    Set WDa = Worksheets("main")
    CDaMxRow = WDa.Range("B" & Rows.Count).End(xlUp).Row
    
    DeleteDenpyou
    BangouFuri
    
    SKey = "B1"
    Narabikae
    
    CreateDenpyou
    
    SKey = "A1"
    Narabikae
    
    DeleteBangou
End Sub

Private Sub DeleteDenpyou()
    Application.DisplayAlerts = False
    For Each Ws In Worksheets
        Select Case Left(Ws.Name, 4)
            Case "main"
            Case Else
                Ws.delete
        End Select
    Next Ws
    Application.DisplayAlerts = True
End Sub

Private Sub BangouFuri()
    With WDa
        With .Range("A1")
            .Offset(0, 0).Value = "No."
            .Offset(1, 0).Value = .Offset(1, 0).Row
            .Offset(2, 0).Value = .Offset(2, 0).Row
            .Offset(3, 0).Value = .Offset(3, 0).Row
        End With
        .Range("A2:A4").AutoFill Destination:=WDa.Range("A2:A" & CDaMxRow)
    End With
End Sub

Private Sub CreateDenpyou()
    '▼新規シート作成
    CMkRow = 16
    For CDaRow = 2 To CDaMxRow
        If St <> WDa.Range("B" & CDaRow).Value Then
            If CDaRow > 2 Then
                Keisen
            End If
            WOg.Copy after:=Worksheets(Worksheets.Count)
            Set WMk = ActiveSheet
            St = WDa.Range("B" & CDaRow).Value
            WMk.Name = St
            CMkRow = 16
        End If
        Dtda = WDa.Range("C" & CDaRow).Value
        '▼データ転記
        With WMk
            '[1]
            .Range("B" & CMkRow).Value = Format(Dtda, "yy")
            .Range("C" & CMkRow).Value = Format(Dtda, "mm")
            .Range("D" & CMkRow).Value = Format(Dtda, "dd")
            '[2]
            .Range("E" & CMkRow).Value = WDa.Range("D" & CDaRow).Value
            .Range("F" & CMkRow).Value = WDa.Range("F" & CDaRow).Value
            .Range("H" & CMkRow).Value = WDa.Range("F" & CDaRow).Value
            '[3]
            If WDa.Range("G" & CDaRow).Value > 0 Then
                .Range("I" & CMkRow).Value = WDa.Range("G" & CDaRow).Value
            Else
                .Range("J" & CMkRow).Value = WDa.Range("G" & CDaRow).Value
            End If
            '[4]
            If CMkRow = 16 Then
                .Range("K" & CMkRow).Value = _
                    WorksheetFunction.Sum(.Range("I16:J16"))
            Else
                .Range("K" & CMkRow).Value = _
                    .Range("K" & CMkRow - 1).Value + _
                    WorksheetFunction.Sum(.Range("I" & CMkRow & ":J" & CMkRow))
            End If
        End With
        CMkRow = CMkRow + 1
    Next CDaRow
    Keisen
    WDa.Activate
End Sub

Private Sub Keisen()
    With WMk.Range("B16:K" & CMkRow)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
    End With
End Sub

Private Sub Narabikae()
    With WDa.Sort.SortFields
        .Clear
        .Add Key:=WDa.Range(SKey), Order:=xlAscending
    End With
    With WDa.Sort
        .SetRange WDa.Range("A1").CurrentRegion
        .Header = xlYes
        .Apply
    End With
    WDa.Activate
    WDa.Range("A1").Activate
End Sub

Private Sub DeleteBangou()
    WDa.Range("A1").EntireColumn.ClearContents
End Sub

[ 続きを読む ]  返信件数:2件  [ 動画を見る] 

[8117]発展編1 フォローメールセミナー 第30回

2017-05-12 19:06:15 受講生さんからの投稿です。

wsfunc3.xlsにおいて、
「DaverageEach ws(c), r(0, c), r(1, c)」
と書き、サブプロシジャーを呼び出していますが、配列だけでなく、変数もこのように書けるのですか?
 そうすると、モジュールレベル変数とサブプロシジャーレベル変数を区別しなくても良いし、あと受け渡しをした変数が明示できる分、分かりやすくなると思いました。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[8078]発展編1 フォローメールセミナー 第17回

2017-05-04 15:34:35 受講生さんからの投稿です。

自力でやったのと模範解答を比べると、回数とタイトルと日付をそれぞれ変数に代入してやっていなかったです。そのことに留意して、完成形1~3を作成すると、所要時間が40分→15分に短縮できたので、やり方次第だなと思いました。

あと、現在のwikepediaの書式からsheet1のスタイルにするために、EmEditorを使おうが、Excelを使おうが、上手く行かずに1時間ぐらい色々試して諦めました。やはり、R→Dは難しいですね。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[8071]発展編1 フォローメールセミナー 第13回

2017-05-03 16:28:39 受講生さんからの投稿です。

[1]
まず、プロジェクトXの見出しをどこかから見つけてきてください。

[2]
そして、下のリンクからダウンロードできるファイルの
「Sheet1」にあるようなリストを作成してください!
フォローメールセミナー 第13回sf_13_2A7954F1.zip

一度、こういうキレイなリストを作ってから、
マクロを使って、「完成系1」「完成系2」「完成系3」のように
いろいろと組み合わせを変えていきながら、
研究会のメンバーとの勉強会が実りあるものになるための、
ベストなものを探していきます。
フォローメールセミナー 第13回sf_13_2A7954F1.zip
↑↑↑↑をクリックしたら、オンライン講座のホーム画面が表示されましたが、

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[8065]発展編1 フォローメールセミナー 第9回

2017-05-01 18:59:27 受講生さんからの投稿です。

お世話になっております。
フォームボタンの件ですが、以下のようなサブプロシジャーの記述がなくても、Excel2007の場合は、作成されたボタンを右クリックし、マクロの登録を行っても、大丈夫ですよね?
Private Sub CommandButton2_Click()

DeleteSheets

End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[7585]発展編1 フォローメールセミナー 第30回

2017-02-01 00:54:50 受講生さんからの投稿です。


こんにちは小川先生。
今迄講座を受け得た知識で過去に作ったマクロがあります。
今回、WorksheetFunctionを勉強させてもらったので、変更してWorksheetFunction.VLookupを取り込んでみようとしました。
しかしマクロを実行すると、VLookupで参照するシートには内容変更が起こらないようにシートの保護をしてあります。
シート保護をしてある状態でもWorksheetFunctionで保護の解除を求められない方法はありますか?
下記のようなマクロでシートの保護はWorksheets("shaban")にかかっています。

Sub VL()
    Dim c As Integer
    Dim e As Integer
    Dim s1 As Worksheet
    Dim i As String
    
    e = Range("C65536").End(xlUp).Row
    Set s1 = Worksheets("aaa")

' シートを保護していると使えない?
' シート保護を解除するマクロが必要?
    
    For c = 6 To e
        
'        Worksheets("shaban").Unprotect ←このようにしてみたが結局パスワードを求められる…
        
        i = s1.Range("C" & c).Value
        s1.Range("D" & c).Value = Application.WorksheetFunction.VLookup(i, Worksheets("shaban").Range("A2").CurrentRegion, 2, False)

'         Worksheets("shaban").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True ←よくわからない
   
    Next
End Sub


ご教授お願い致します。
また、発展編1を受講中ですがもう一度復習したのち次のステップに進もうと思ってます。
時間を作りながら勉強している状態でペースは遅いのですが次はどの講義を受講するのが良い手段ですか?
よろしくお願いします。

[ 続きを読む ]  返信件数:2件  [ 動画を見る] 

[7542]発展編1 フォローメールセミナー 第11回

2017-01-21 23:29:13 受講生さんからの投稿です。

小川先生、いつもお世話になっております。
印刷範囲とヘッダーを追加した伝票作成マクロの作成を致しました。

モジュールレベルの変数とプロシージャレベルの変数をうまく使い分けることがまだ難しいように感じました。
添削の程、何卒よろしくお願いします。

Option Explicit
Dim Mn As Worksheet
Dim Mn1 As Worksheet
Dim Amax As Long
 
Sub Denpyo_making()
    Set Mn = Worksheets("main")
    Set Mn1 = Worksheets("main1")
    Amax = Mn.Range("B65536").End(xlUp).Row
    
    Deletesheets1
    Numbering
    Narabikae
    sheets_making
    Narabikae2
    syuseiH_C

End Sub

Sub Deletesheets1()
    Dim Ws As Worksheet
    Application.DisplayAlerts = False
    For Each Ws In Worksheets
        If Left(Ws.Name, 4) <> "main" Then
            Ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Sub Numbering()

    Mn.Range("A2").Value = 1
    Mn.Range("A2").AutoFill _
        Mn.Range("A2:A" & Amax), xlFillSeries

End Sub

Sub Narabikae()
    Mn.Sort.SortFields.Clear
    Mn.Sort.SortFields.Add Key:= _
        Range("B1"), Order:=xlAscending
    With Mn.Sort
        .SetRange Range("A1:G" & Amax)
        .Header = xlYes
        .Apply
    End With
End Sub

Sub sheets_making()
    Dim Namae As String
    Dim gyo As Long
    Dim Nws As Worksheet
    Dim dt As Date '日付
    Dim saki As Long
    
    For gyo = 2 To Amax
        If Namae <> Mn.Range("B" & gyo).Value Then
            If gyo > 2 Then
                keisen_making '最初だけ罫線回避
            End If
            Namae = Mn.Range("B" & gyo).Value
            Sheets("main1").Copy After:=Sheets(Sheets.Count)
            Sheets("main1 (2)").Select
            Sheets("main1 (2)").Name = Namae
            Set Nws = Worksheets(Namae)
            saki = 16
        End If

        dt = Mn.Range("C" & gyo).Value
        Nws.Range("B" & saki).Value = Right(Year(dt), 2)
        Nws.Range("C" & saki).Value = Month(dt)
        Nws.Range("D" & saki).Value = Day(dt)
        Nws.Range("F2").Value = Mn.Range("B" & gyo).Value
        Nws.Range("E" & saki).Value = Mn.Range("D" & gyo).Value
        Nws.Range("F" & saki).Value = Mn.Range("E" & gyo).Value
        Nws.Range("H" & saki).Value = Mn.Range("F" & gyo).Value
        
        If Mn.Range("G" & gyo).Value > 0 Then
            Nws.Range("I" & saki).Value = Mn.Range("G" & gyo).Value
        Else
            Nws.Range("J" & saki).Value = Mn.Range("G" & gyo).Value
        End If
        Nws.Range("K" & saki).Value = Nws.Range("I" & saki).Value + Nws.Range("J" & saki).Value
        saki = saki + 1
    Next
    keisen_making '最後の会社のシートに罫線つける
End Sub

 Sub keisen_making()
    Dim cNewmax
    cNewmax = Range("B65536").End(xlUp).Row
    Range("B16:K" & cNewmax).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

Sub Narabikae2()
    Mn.Sort.SortFields.Clear
    Mn.Sort.SortFields.Add Key:= _
        Range("C1"), Order:=xlAscending
    With Mn.Sort
        .SetRange Range("A2:G" & Amax)
        .Header = xlYes
        .Apply
    End With
    Mn.Range("A2").Value = ""
    Mn.Range("A2").AutoFill _
        Mn.Range("A2:A" & Amax), xlFillSeries
    
End Sub
    
Sub syuseiH_C()
    Dim cNewmax As Long
    Dim c As Long
    Dim Wh As Worksheet
    cNewmax = Range("B65536").End(xlUp).Row
    
    For Each Wh In Worksheets
        If Left(Wh.Name, 4) <> "main" Then
            With Wh.PageSetup
                .LeftHeader = Wh.Name
                .RightHeader = "&D"
                .Zoom = 100
                .PrintErrors = xlPrintErrorsDisplayed
                .OddAndEvenPagesHeaderFooter = False
                .DifferentFirstPageHeaderFooter = False
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = False
            End With
            ActiveSheet.PageSetup.PrintArea = "A1:K" & cNewmax
        End If
    Next
End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[7355]発展編1 フォローメールセミナー 第23回

2016-12-04 08:59:47 平吹 敦史さんからの投稿です。

お世話になります。
Formulaプロパティは、最初違いがよくわかりませんでしたが、簡単なテストをして、よくわかりました。今までは、数式はExcelで事前につくっておいて、それ以外をvbaで処理していました。
数式そのものもvbaで処理できることがわかり、幅が広がりそうです。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[7323]発展編1 フォローメールセミナー 第11回

2016-11-22 18:18:32 受講生さんからの投稿です。

小川先生
お世話になっております。
10月末から勉強させていただいております。
複数シート間で処理をするときのプログラムの書き方がまだしっかりと身についていません。
また変数名を何にするか決めるのに時間がかかり決めた変数名に自信が持てません。
引き続き身につくよう勉強していきます。
読みにくいコードとなり申し訳ありませんがご確認お願いいたします。

Sub denpyoMake()
'mainシートの取引先名称ごとにシートを分ける

    Dim shFm As Worksheet
    Dim shTo As Worksheet
    Dim sortMaeNum As Long
    Dim sortMaeNumMx
    Dim lnfm As Long
    Dim lnfmMx As Long
    Dim lnTo As Long
    Dim dt As Date
    
    Set shFm = Worksheets("main")
    
    'main、main1以外のシートを削除
    deleteSheet
    
    sortMaeNumMx = Range("B" & Rows.Count).End(xlUp).Row
    For sortMaeNum = 2 To sortMaeNumMx
        shFm.Range("A" & sortMaeNum).Value = sortMaeNum - 1
    Next sortMaeNum
    
    'mainシートでソートする
    sortTorihiki
    
    lnfmMx = Range("B" & Rows.Count).End(xlUp).Row
    For lnfm = 2 To lnfmMx
        If shFm.Range("B" & lnfm).Value <> shFm.Range("B" & lnfm - 1).Value Then
            If lnfm <> 2 Then
                '罫線を引く
                keisenDraw (lnTo)
            
                '印刷範囲を設定する
                printSetting (lnTo)
            End If
            
            Worksheets("main1").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = shFm.Range("B" & lnfm).Value
            Set shTo = ActiveSheet
            shTo.Range("F2").Value = shTo.Name
            lnTo = 16
        Else
            lnTo = lnTo + 1
        End If
        dt = shFm.Range("C" & lnfm).Value
        shTo.Range("B" & lnTo).Value = Right(Year(dt), 2)
        shTo.Range("C" & lnTo).Value = Month(dt)
        shTo.Range("D" & lnTo).Value = Day(dt)
        shTo.Range("E" & lnTo).Value = shFm.Range("D" & lnfm).Value
        shTo.Range("F" & lnTo).Value = shFm.Range("E" & lnfm).Value
        shTo.Range("H" & lnTo).Value = shFm.Range("F" & lnfm).Value
        If shFm.Range("G" & lnfm).Value > 0 Then
            shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnfm).Value
        Else
            shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnfm).Value
        End If
        shTo.Range("K" & lnTo).Value = shTo.Range("K" & lnTo - 1).Value + shFm.Range("G" & lnfm).Value
            
    Next lnfm
    
    'mainシートを元の順番でソートする
    sortMotojun

    shFm.Activate
    shFm.Range("A1").Select
    
End Sub

Private Sub sortTorihiki()
'取引先名称で並び替える
    
    Columns("A:G").Select
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("C:C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("D:D"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("F:F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Worksheets("main").Range("A1").Value = "No"
End Sub

Private Sub sortMotojun()
'元の並び順に並び替える
    
    Columns("A:G").Select
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A:A").ClearContents
End Sub

Private Sub deleteSheet()
' main、main1以外のシートを削除する

    Application.DisplayAlerts = False
    Dim sh As Worksheet
    For Each sh In Worksheets
        If Left(sh.Name, 4) <> "main" Then
            sh.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Private Sub keisenDraw(mxGyo As Long)
'追加シートに罫線を引く

    With Range("B16:K" & mxGyo)
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
End Sub

Private Sub printSetting(maxGyo As Long)
'印刷範囲を変更する。またヘッダ・フッタを入れる。

Range("A1:L" & maxGyo).Select
    ActiveSheet.PageSetup.PrintArea = "A1:L" & maxGyo + 1
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = "&D"
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = "&A"
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 10
        .FitToPagesTall = 10
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[5661]発展編1 フォローメールセミナー 第11回

2016-01-24 15:06:17 受講生さんからの投稿です。

小川先生、いつもお世話になっております。
追加要件の宿題を提出いたします。前回の宿題提出時に頂いたご指導のお陰で、ループの初回の罫線設定回避策もよく理解出来て、スラスラと書けるようになりました。
今回はオートフィルでA列に番号を振る別解としました。オートフィルのハンドル部分をダブルクリックするだけで、表がある部分全てにオートフィルが実行されることは知らなかったので、
また新たな学びが出来ました。(今更というカンジですが…(;・∀・))添削ご指導よろしくお願いいたします。

Sub creatDenpyo()
    deleteDenpyo
    
    Dim wFm As Worksheet
    Set wFm = Worksheets("main")
    Dim wTmp As Worksheet
    Set wTmp = Worksheets("main1")
    Dim wTo As Worksheet
    
    '(1)A列に番号を振る(オートフィルで)
    wFm.Range("A2").FormulaR1C1 = "1"
    wFm.Range("A3").FormulaR1C1 = "2"
    wFm.Range("A2:A3").AutoFill Destination:=wFm.Range("A2:A317")

    '(2)B列でソート
    wFm.Range("A1:G317").Sort Key1:=wFm.Range("B1"), Order1:=xlAscending, Header:=xlYes

    '(3)伝票テンプレートにヘッダー/フッター挿入、印刷範囲設定クリア
    With wTmp.PageSetup
        .CenterHeader = "&A"
        .CenterFooter = "&P / &N ページ"
        .PrintArea = ""
    End With
    
    '(4)伝票作成
    Dim gyo As Long
    Dim gyoMax As Long
    gyoMax = wFm.Range("B" & Rows.Count).End(xlUp).Row
    Dim gyoTo As Long
    gyoTo = 16
    For gyo = 2 To gyoMax
        If wFm.Range("B" & gyo).Value <> wFm.Range("B" & gyo - 1).Value Then
            If gyo > 2 Then
                keisen
            End If
            gyoTo = 16
            wTmp.Copy After:=Sheets(2)
            Set wTo = ActiveSheet
            wTo.Name = wFm.Range("B" & gyo).Value
        End If
        wTo.Range("B" & gyoTo) = Mid(Year(wFm.Range("C" & gyo).Value), 3)
        wTo.Range("C" & gyoTo) = Month(wFm.Range("C" & gyo).Value)
        wTo.Range("D" & gyoTo) = Day(wFm.Range("C" & gyo).Value)
        wTo.Range("E" & gyoTo) = wFm.Range("D" & gyo).Value
        wTo.Range("F" & gyoTo) = wFm.Range("E" & gyo).Value
        wTo.Range("H" & gyoTo) = wFm.Range("F" & gyo).Value
        If wFm.Range("G" & gyo).Value > 0 Then
            wTo.Range("I" & gyoTo) = wFm.Range("G" & gyo).Value
        Else
            wTo.Range("J" & gyoTo) = wFm.Range("G" & gyo).Value
        End If
        If gyoTo > 16 Then
            wTo.Range("K" & gyoTo) = wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value + wTo.Range("K" & gyoTo - 1).Value
        Else
            wTo.Range("K" & gyoTo) = wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value
        End If
        gyoTo = gyoTo + 1
    Next
    keisen

    '(5)A列でソート
    wFm.Range("A1:G317").Sort Key1:=wFm.Range("A1"), Order1:=xlAscending, Header:=xlYes

    '(6)A列の値消去
    wFm.Range("A1:A317").ClearContents
End Sub

Sub deleteDenpyo()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "main1" And ws.Name <> "main" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Sub keisen()
    Dim gyoMax
    gyoMax = Range("B" & Rows.Count).End(xlUp).Row
    
    With Range("B16", "K" & gyoMax)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
    End With
End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[5633]発展編1 フォローメールセミナー 第9回

2016-01-17 19:19:22 受講生さんからの投稿です。

小川先生、いつも大変お世話になっております。

昨年12月から受講開始した発展編の視聴が一通り終了しましたので、
年明けからフォローアップメールセミナーの伝票作成マクロに取り掛かってきました。
発展編での学びを定着させるのにとても勉強になっております。
実務の方でも非常に役に立っており、大変感謝致しております。

この伝票作成マクロの動画を通じて、withブロックの中身を置換でシンプルに修正する方法が
大変参考になりました。
またテスト時のブレークポイントの設定についても良い復習となり、
実務の方で活かしていきたいと実感しました。

以下に宿題を投稿させて頂きます。
先生の動画を視聴した直後に作成しましたので、殆ど先生のコードと違わないとは思いますが、
いざ自分で作ってみるとなると、罫線を引くタイミングが難しくて、
特にmainシートに罫線が引かれてしまう時の回避策がどうしても思いつかず、
単純に、”シート名がmainでなければ”、という表現となってしまいましたが・・・(・∀・;)
よろしくお願いいたします。


Sub deleteDenpyo()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "main" And ws.Name <> "main1" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Sub createDenpyo()
    deleteDenpyo
    
    Dim wFm As Worksheet
    Dim wTo As Worksheet
    Set wFm = Worksheets("main")

'日付の昇順に番号振る
    Dim gyoMax As Long
    gyoMax = wFm.Range("B" & Rows.Count).End(xlUp).Row
    Dim gyo As Long
    For gyo = 2 To gyoMax
        wFm.Range("A" & gyo).Value = gyo - 1
    Next
    
'B列ソート
    wFm.Range("A2:G317").Sort Key1:=wFm.Range("B1"), Order1:=xlAscending, Header:=xlYes
    
'伝票作成
    Dim gyoTo As Long
    For gyo = 2 To gyoMax
        '取引先名称が違えばシートを作る
        If wFm.Range("B" & gyo).Value <> wFm.Range("B" & gyo - 1).Value Then
            If ActiveSheet.Name <> "main" Then
                keisen
            End If
            Sheets("main1").Copy After:=Sheets(2)
            Set wTo = Sheets("main1 (2)")
            wTo.Name = wFm.Range("B" & gyo).Value
            gyoTo = 16
        End If
        'シートを作成後、データを投入していく
        wTo.Range("B" & gyoTo).Value = Mid(Year(wFm.Range("C" & gyo).Value), 3)
        wTo.Range("C" & gyoTo).Value = Month(wFm.Range("C" & gyo).Value)
        wTo.Range("D" & gyoTo).Value = Day(wFm.Range("C" & gyo).Value)
        
        wTo.Range("E" & gyoTo).Value = wFm.Range("D" & gyo).Value
        wTo.Range("F" & gyoTo).Value = wFm.Range("E" & gyo).Value
        wTo.Range("H" & gyoTo).Value = wFm.Range("F" & gyo).Value
        If wFm.Range("G" & gyo).Value > 0 Then
            wTo.Range("I" & gyoTo).Value = wFm.Range("G" & gyo).Value
        Else
            wTo.Range("J" & gyoTo).Value = wFm.Range("G" & gyo).Value
        End If
        If gyoTo = 16 Then
            wTo.Range("K" & gyoTo).Value = wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value
        Else
            wTo.Range("K" & gyoTo).Value = wTo.Range("K" & gyoTo - 1).Value + wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value
        End If
        gyoTo = gyoTo + 1
    Next
        keisen
End Sub

Sub keisen()
    Dim gyoToMax
    gyoToMax = Range("B" & Rows.Count).End(xlUp).Row
    Range("B16:K" & gyoToMax).Select
    
    With Range("B16:K" & gyoToMax)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
    
    End With
    
End Sub


[ 続きを読む ]  返信件数:3件  [ 動画を見る] 

[5543]発展編1 フォローメールセミナー 第12回

2016-01-10 06:45:32 山田 将之さんからの投稿です。

必ずこれをするようにします。ありがとうございました。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[5097]発展編1 フォローメールセミナー 第14回

2015-09-25 08:51:16 虫谷吉男さんからの投稿です。

WEBのデータは一度テキストエディタに落としてからエクセルに貼り付けるとスムーズなんですね。
知り得てよかったです。そのままエクセルにベタ貼りするのと全然違いました。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[4984]発展編1 フォローメールセミナー 第29回

2015-09-01 23:12:26 森 則彦さんからの投稿です。

小川先生、お世話になっております。発展編フォローセミナーNo.29のカレンダー問題がようやく自分なりの解釈で何とか出来ました。
予習の意味で新しい構文を使ってみました。作り込む最中で色々なアイデアを試しながら出来、再発見、再確認ができました。
今回はいかに効率よく走るかを私なりに考えてつくりました。先生のご感想よろしくお願いします。先生のNO.29のメールからダウンロードしたファイルの中に、ControlのシートがなかったのでNO.26のファイルを使用して、祭日には、文字を赤、背景を黄色とする、前提条件としました。後で思ったのですが、
Summaryのシートにデータを入れるタイミングは1か月分が出来上がった段階で一気にそれをコピーした方がスピードが速いのではないかなと思いました。プログラムは出来上がりは同じでも課程はいろいろある所がじつに面白いですね。もっといろいろな構文、アルゴリズムを勉強すればさらにプログラミングの世界が広がる思うと、今後がたのしみです。上級編もまた、お願いしたいと思います。では、先生の感想をお待ちしております。
追伸。2015年のカレンダーにしました。

code

Dim dStart As Date, wNa As Integer
Dim list(6, 2) As Variant, sAijitu(16, 2) As Variant

Private Sub CalenCre()
CreMSht
dStart = #1/1/2015#
Dim mCnt As Long
Dim cOnws As Worksheet
Dim c As Integer
Set cOnws = Worksheets("Control")
With cOnws.Range("a2")
For c = 0 To 6
list(c, 0) = c + 1
list(c, 1) = .Offset(c).Interior.ColorIndex
list(c, 2) = .Offset(c).Font.ColorIndex
Next
End With
With cOnws.Range("c2")
For c = 0 To 16
sAijitu(c, 0) = .Offset(c).Value
sAijitu(c, 1) = .Offset(c).Interior.ColorIndex
sAijitu(c, 2) = .Offset(c).Font.ColorIndex
Next
End With
Worksheets("Summary").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "dami"
For mCnt = 1 To 12
Worksheets("dami").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = mCnt & "月"
calen_exe
dStart = DateAdd("m", 1, dStart)
Next
Application.DisplayAlerts = False
Worksheets("dami").Delete
Application.DisplayAlerts = True
Worksheets("Summary").Activate
End Sub

Public Sub calen_exe()
Dim dCnt As Date, sAicnt As Integer, mEmo
Dim c As Long, cYoko As Long, mAx As Long, yOucnt As Integer
Dim jyuS As String
Dim sH As Worksheet
Set sH = Worksheets("Summary")
Dim rg As Range
mAx = sH.Range("a" & Rows.Count).End(xlUp).Row
Set rg = sH.Range("a" & mAx + 1)
dCnt = dStart
c = 0
With Range("a2")
Do While Month(dCnt) = Month(dStart)
.Offset(c, 0).Value = dCnt
wNa = Weekday(dCnt)
.Offset(c, 1).Value = WeekdayName(wNa)
.Offset(c, 2).Value = #9:00:00 AM#
.Offset(c, 3).Value = #5:00:00 PM#
jyuS = "=" & .Offset(c, 3) & "-" & .Offset(c, 2).Value
.Offset(c, 4).Formula = jyuS
For cYoko = 0 To 4
rg.Offset(c, cYoko).Formula = "='" & .Worksheet.Name & "'!" & .Offset(c, cYoko).Address
Next
For sAicnt = mEmo To 16
If dCnt = sAijitu(sAicnt, 0) Then
With Range(rg.Offset(c, 0), rg.Offset(c, 4))
.Interior.ColorIndex = sAijitu(sAicnt, 1)
.Font.ColorIndex = sAijitu(sAicnt, 2)
End With
With Range(.Offset(c, 0), .Offset(c, 4))
.Interior.ColorIndex = sAijitu(sAicnt, 1)
.Font.ColorIndex = sAijitu(sAicnt, 2)
End With
mEmo = mEmo + 1
GoTo line1
End If
Next
For yOucnt = 0 To 6
If wNa = list(yOucnt, 0) Then
With Range(rg.Offset(c, 0), rg.Offset(c, 4))
.Interior.ColorIndex = list(yOucnt, 1)
.Font.ColorIndex = list(yOucnt, 2)
End With
With Range(.Offset(c, 0), .Offset(c, 4))
.Interior.ColorIndex = list(yOucnt, 1)
.Font.ColorIndex = list(yOucnt, 2)
End With
GoTo line1
End If
Next
line1:
dCnt = DateAdd("d", 1, dCnt)
c = c + 1
Loop
End With
End Sub

Public Sub CreMSht()
Dim wS As Worksheet
Dim orWs As Worksheet, nEwws As Worksheet, orCws As Worksheet
Set orWs = Worksheets("Summary")
Set orCws = Worksheets("Control")
Application.DisplayAlerts = False
For Each wS In Worksheets
If Not (wS Is orWs Or wS Is orCws) Then
wS.Delete
End If
Next
Application.DisplayAlerts = True
clean
End Sub

Public Sub clean()
Worksheets("Summary").Activate
Dim gyo As Long
gyo = Range("a" & Rows.Count).End(xlUp).Row
If gyo > 1 Then
With Range("a2", "e" & gyo)
.ClearContents
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 0
End With
End If
End Sub

/code

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[4908]発展編1 フォローメールセミナー 第9回

2015-08-21 00:22:31 森 則彦さんからの投稿です。

小川先生、お世話になっております。
ちょっと時間はかかりましたが何とか出来ました。

コレクションの概念をたえず意識しながら、自分なりにNETや、本などで勉強しつつ、
先生の考え方を参考にして、違った表現で書いてみました

最初よりは、やりたいことが何となくスラスラとイメージ出来る様になった気がします。
また、他の人が書いたプログラムも読める様になったと思います。

先生から見ればまだまだ知らない初心者でレベルの低い話ではあると思いますが、
他の人の書いたものも参考にしつつスラスラと出来る様になると、遥かかなたのVBAの達人。
頂上に向かって登っているときは楽し~いものですね。何歳になっても。

以下が練習問題の私の今の力の回答です。感想よろしくお願いします。


code
Sub ren212()
DeleteSheets

Dim fmWs As Worksheet, toWs As Worksheet, orWs As Worksheet
Dim rG As Range, aLrg As Range, keiSen As Range
Dim kaiSya As String
Dim mX As Long, toCnt As Long, kEi As Long, kGaku As Long
Set fmWs = Worksheets("main1")
Set orWs = Worksheets("main")
orWs.Range("b1").Sort key1:=Range("b1"), order1:=xlAscending, Header:=xlYes
mX = Range("b" & Rows.Count).End(xlUp).Row
Set aLrg = orWs.Range("b2", "b" & mX)
For Each rG In aLrg
If Not kaiSya = rG Then
If Not kaiSya = "" Then
Set keiSen = Worksheets(kaiSya).Range("b16", "k" & 15 + toCnt)
keiSen.Borders.LineStyle = xlContinuous
End If
fmWs.Copy after:=Worksheets(Worksheets.Count)
Set toWs = ActiveSheet
kaiSya = rG.Value
toWs.Name = kaiSya
kEi = 0
toCnt = 0
End If
With toWs.Range("b16")
.Offset(toCnt, 0).Value = Right(Year(rG.Offset(, 1).Value), 2)
.Offset(toCnt, 1).Value = Month(rG.Offset(, 1).Value)
.Offset(toCnt, 2).Value = Day(rG.Offset(, 1).Value)
.Offset(toCnt, 3).Value = rG.Offset(, 2).Value
.Offset(toCnt, 4).Value = rG.Offset(, 3).Value
.Offset(toCnt, 6).Value = rG.Offset(, 4).Value
kGaku = rG.Offset(, 5).Value
If kGaku >= 0 Then
.Offset(toCnt, 7).Value = kGaku
Else
.Offset(toCnt, 8).Value = kGaku
End If
kEi = kEi + kGaku
.Offset(toCnt, 9).Value = kEi
End With
toCnt = toCnt + 1
Next
Set keiSen = Worksheets(kaiSya).Range("b16", "k" & 15 + toCnt)
keiSen.Borders.LineStyle = xlContinuous
orWs.Activate
orWs.Range("a1").Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlYes
End Sub


Sub DeleteSheets()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
If Not ws.Name Like "main*" Then
ws.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
/code

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[4887]発展編1 フォローメールセミナー 第9回

2015-08-16 18:36:15 受講生さんからの投稿です。

小川先生

ようやく宿題ができました。まる一日かかってしまいましたが、なんとか動きました。よろしくお願いいたします。
From  岡田 まさこ

option explicit
Sub denpyo_sakusei_homework()
    denpyo_sakujo
    narabekae
    sheetsakusei
End Sub

'以下はそれぞれの部品です。

Sub denpyo_sakujo()            '部品1
    Dim ws As Worksheet
    
 Application.DisplayAlerts = False
 
    For Each ws In Worksheets
        If Left(ws.Name, 4) <> "main" Then
            ws.Delete
        End If
    Next
 Application.DisplayAlerts = True
 
End Sub

Sub narabekae()    '部品2
Dim wfm As Worksheet
Set wfm = Worksheets("main")

    wfm.Range("A2").FormulaR1C1 = "1"
    wfm.Range("A3").FormulaR1C1 = "2"
    wfm.Range("A4").FormulaR1C1 = "3"
    wfm.Range("A2:A4").AutoFill Destination:=Range("A2:A317")
    
    wfm.Sort.SortFields.Clear
    wfm.Sort.SortFields.Add Key:=Range("B2:B317"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wfm.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    


End Sub

Sub sheetsakusei()        '部品3
    Dim wfm As Worksheet
    Dim wto As Worksheet
    Dim cfm As Long
    Dim mx As Long
    Dim cto As Long
    
    Set wfm = Worksheets("main")
    Set wto = Worksheets("main1")
     mx = Range("B" & Rows.Count).End(xlUp).Row
    
    For cfm = 2 To mx
      
        If wfm.Range("B" & cfm).Value <> wfm.Range("B" & cfm - 1).Value Then
            If cfm > 2 Then
                keisen
            End If
       
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
             Set wto = ActiveSheet
            wto.Name = wfm.Range("B" & cfm).Value
         cto = 16
        End If
     
        If wto.Name = wfm.Range("B" & cfm).Value Then
            wto.Range("E" & cto).Value = wfm.Range("D" & cfm).Value
            wto.Range("F" & cto).Value = wfm.Range("E" & cfm).Value
            wto.Range("H" & cto).Value = wfm.Range("F" & cfm).Value
            wto.Range("J12").Value = wfm.Range("B" & cfm).Value
            
            wto.Range("B" & cto).Value = Right(Year(wfm.Range("C" & cfm).Value), 2)
            wto.Range("C" & cto).Value = Month(wfm.Range("C" & cfm).Value)
            wto.Range("D" & cto).Value = Day(wfm.Range("C" & cfm).Value)
            
            If wfm.Range("G" & cfm).Value > 0 Then
                wto.Range("I" & cto).Value = wfm.Range("G" & cfm).Value
            Else
                wto.Range("J" & cto).Value = wfm.Range("G" & cfm).Value
            End If
         
  
         
         Dim c As Range
         Set c = wto.Range("K" & cto)
            If cto = 16 Then
                c = c.Offset(0, -2).Value + c.Offset(0, -1).Value
            Else
                c = c.Offset(-1, 0).Value + c.Offset(0, -2).Value + c.Offset(0, -1).Value
            End If
            cto = cto + 1
        End If
      
    Next
    keisen
    
    Worksheets("main").Activate


    wfm.Sort.SortFields.Clear
    wfm.Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wfm.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Columns("A:A").ClearContents
    
End Sub

Sub keisen()          '部品4
    Dim kmx As Long
    kmx = Range("K" & Rows.Count).End(xlUp).Row

    With Range("B16:K" & kmx + 1)
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    End With
    

End Sub

[ 続きを読む ]  返信件数:3件  [ 動画を見る] 

[4473]発展編1 フォローメールセミナー 第24回

2015-06-09 06:16:18 山田 将之さんからの投稿です。

ありがとうございます。with構文、offset,do loopの活用の仕方理解できました。
動画を見て復習してすっきりしました。感謝します。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[3963]発展編1 フォローメールセミナー 第18回

2015-03-14 19:10:44 佐々木久さんからの投稿です。

他のセルで F2 alt + enter を押して、
rvalue_rvalue を実行しても、改行が削除されないのですが
何か方法が間違っているのでしょうか?

佐々木

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[3627]発展編1 フォローメールセミナー 第2回

2015-01-16 23:58:24 ゲストさんからの投稿です。

初心者です。

初めてなのでわからないことだらけなのですが、、
少しずつできるようになれるように楽しみながらやっていきたいです。よろしくお願いします。
シートをコピーして、名前をつける、マクロがまだ一人でできない状況です。


以下だと、何が問題なのか自分では解明できなくて、教えていただきたいのですが。

①active sheetsのままがいけませんか。
②まだ、はなこのステップのはこのどこに、どこまでのお団子をいれたらいいか、よくわかっていません。また、変数を定義する場所もよくわかっていません。

アドバイスをいただけると幸いです。よろしくお願いします。  (渡辺早紀)



'シート「main」にある各取引先の名称のシートを作れ
'(シートには何も記載されていなくてよい)
'ヒント: [1] シートを追加するマクロを作ってみる
' [2] [1]で作ったマクロで、さらに、その直後に、作ったシートの名前を変更するようにする
' [3] [2]で作ったマクロで、作ったシートの名前を、シート「main」のセルB2の値になるようにする
' [4] [3]で作ったマクロで、シート「main」の2行目から21行目までで連続作業をするよう改変する

------------------------------------

Sub shadd()

Dim gyo 'エラーメッセージが、「この名前は既に使用されています。別の名前を使用してください。」となってしまう。。

For gyo = 2 To 21

Worksheets.Add


ActiveSheet.Select
ActiveSheet.Name = Worksheets("main").Range("B" & gyo).Value


Next


End Sub





[ 続きを読む ]  返信件数:3件  [ 動画を見る] 

[3300]発展編1 フォローメールセミナー 第25回

2014-11-06 23:01:54 受講生さんからの投稿です。

このあたりになるとかなり難しく感じられるため、何とか読めても一から書けと言われると無理です。
今回の場合はシート名が数字から始まるために「'」でシート名が囲まれているのだと思うのですが、
「'」を付け忘れても自動で補完されるように思えます。
それでも「'」は意識的につけた方がいいのでしょうか?

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[2886]発展編1 フォローメールセミナー 第24回

2014-11-04 21:27:31 受講生さんからの投稿です。

WithとOffsetの連携により、定数を使わなくても可読性・メンテナンス性がいいものができることが分かりました。
課題は何とかできましたが、あまり自信がありません。とにかく動くものを作るだけで精一杯です。
明日の解説で確認します。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[2883]発展編1 フォローメールセミナー 第23回

2014-11-03 19:41:30 受講生さんからの投稿です。

曜日はFormat関数を使用し、数式を入れる部分は、R1C1形式を使ってしまいました。
Addressプロパティを使用すると、可読性が良くなるのですね。ついでに相対参照にしておきました。
課題[3]でOffsetを使いWithでまとめる方法は、参考になりました。
課題[4]はよく分からなかったので、明日の解答を確認してみます。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[2879]発展編1 フォローメールセミナー 第22回

2014-11-03 09:31:26 受講生さんからの投稿です。

月末を求めるのではなく、月が同じである間ループを繰り返すという発想、
一度作成したプロシージャを分割していくという発想が、大変参考になりました。
何度も手を動かしながら、身につけていきたいと思います。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[2878]発展編1 フォローメールセミナー 第21回

2014-11-03 09:24:18 受講生さんからの投稿です。

この例のように、1列でもSelectionが活躍するのですね。
範囲選択せずに実行してしまうことが多いのですが、徐々に慣れていきたいと思います。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[2860]発展編1 フォローメールセミナー 第20回

2014-10-31 20:08:46 受講生さんからの投稿です。

アイデア次第で、いろいろな使い方があるのですね。
こういうマクロをサクッと作れるようになりたいです。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[2857]発展編1 フォローメールセミナー 第19回

2014-10-30 20:11:23 受講生さんからの投稿です。

今までStep -1で対応していました。
>Rows(48 - ln & ":" & 48 - ln).Delete
":"はつけなくても動作すると思うのですが、つけた方がいいのでしょうか?

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[2856]発展編1 フォローメールセミナー 第18回

2014-10-30 20:10:16 受講生さんからの投稿です。

使い捨てのマクロでは"Selection"で楽ができるのですね。参考になります。
改行は今までvbLfかvbCrLfを使用していたため、vbNewLineを初めて知りました。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

12>

各講座ごとのメッセージを見る場合はこちら

 

まずはここから!スマホでも学べる無料動画講座

今なら先着30名限定で無料!定価4,800円の、初心者のためのエクセルマクロ動画講座。
  1. Excel 97~Excel 2016まですべて対応。動画本数20本、総再生時間2時間44分53秒
  2. PC, Mac, iPhone, iPad, Androidのお好みの環境で、いつでも好きなときに学べます。
2004年から10年間述べ3,000名以上に実施した研修の経験と実績を集約した講座です。
いますぐ無料で試してください。

トップへ