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

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

[12875]「クラス」と「インスタンス」について

2021-01-26 22:57:54 受講生さんからの投稿です。

58歳、新米プログラマーです。
クラスとインスタンスの関係はわかるのですがオブジェクトの概念がどうもよくわかりません。例えばセルというオブジェクトがあり、そのひな形として様々なプロパティを持ったり、動作(メソッド)ができたりするようになっている。初期値も決められている。A1に具体的な実態を伴ったセルを作ったときにそれがインスタンスで固有の列幅や網掛け色などを持っています。ここまではあっているような気がしています。
一方、動画の3分を超えたあたりのコメントに関する先生の説明で使われる「オブジェクト」の意味がどうもしっくりきません。
「…コメントのクラスというのがあって、コメントの発注をした。そうするとEXCELがコメントの◆オブジェクトを作って◆最低限の設定だけしてそのまま納品した…」の◆で挟んだ部分です。ここでいう「オブジェクトを作る」というのは「インスタンスを作る」ことと何が違うのか?について教えてください。よろしくお願いします。

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

[12854]Functionプロシージャ演習中

2021-01-21 12:46:25 マメコトさんからの投稿です。

ファンクションプロシージャを上手に使いこなせれば、以前はグローバル変数として宣言していたものをかなり減らせるのではないかと思いました。
「どのような処理をどの順番で行うか」
を考えることで、その共通的な処理をファンクション化出来ると思いました。

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

[12837]テキストファイルの操作について

2021-01-17 08:20:56 たかちゃんさんからの投稿です。

複数のCSVファイルを自動で読み込ませるマクロを書いてみました。
・csv内には日付データがない為、ファイル名から日付を取得
・csv内の12項目&日付を配列に入れ、一気にシートに書き出し

csvファイルはこのような感じです。
“ABC1230″,”掃除機”,”,000″…
EmEditorで確認した所、utf-8(BOM有)

苦労した点
・金額の,が区切り文字と判断される
→replaceColonという関数を作成し、区切りのカンマのみ
“:”(コロン)に置き換えた
・データを配列に入れ、エクセルに書き出すと文字化け
→FileSystemObjectの代わりに、ADODB.streamを使用して
CSVを読ませた
・CSV内の改行が認識されなかった
→ADODB.streamのLineSeparatorの値をデフォルトから変更

ほぼ丸一日かかって書き上げ、動いた時は非常に嬉しかった為
記念投稿します。
とても長いのでコメントは気になさらないで下さい(^^)

今度は、データを使用しどのように分析する為のグラフを作ろう・・
と考えてます。ここはVBAと関係ありませんが、。
マクロは奥が深いです。

【参考URL】
https://tonari-it.com/vba-csv-camma/
https://tonari-it.com/vba-csv-utf8/

'Microsoft Scripting Runtimeにチェックを入れる→FileSystemObjectを使用する為
'Microsoft ActiveX Data Objects x.x にチェックを入れる→ADODB.Streamを使用する為
Public Sub CSVファイルをdataシートへ全て書き出し()
    Dim fs As New Scripting.FileSystemObject
    Dim files As Scripting.files
    Dim file As Scripting.file
    Dim strLine As String
    Dim sData As String
    Dim SPcsvData As Variant
    Dim path As String
    Dim fName As String
    Dim cnt As Long
    Dim ar() As Variant
    Dim c As Long
    'utf-8(BOM有) csvファイルの文字化け対策用
    Dim ado_stream As New ADODB.Stream
    
    'CSVファイルは、BusinessReportフォルダの中へ保存しておく
    path = ThisWorkbook.path & "\BusinessReport"
    Set files = fs.GetFolder(path).files
    
    
    cnt = 0 '配列で使用するカウント用
    For Each file In files
         
        'utf-8 csv文字化け対策
        With ado_stream
            .Charset = "utf-8"
            .LineSeparator = 10 '改行されなかったので設定変更
            .Open
            .LoadFromFile (file)
        
        fName = Right(fs.GetBaseName(file), 8) 'ファイル名の日付部分のみを取得、この先の配列0に入れる
        
         ado_stream.SkipLine '1行目(タイトル行)は読まない
        'CSVファイルを2行目から1行づつ読み、ar配列へ格納
        Do Until .EOS
            strLine = .ReadText(adReadLine) '一行読む
            sData = replaceColon(strLine) ',000のカンマも区切りと判断される為、区切りのカンマだけ:に置換
            SPcsvData = Split(sData, ":")
            
            ReDim Preserve ar(12, cnt)
            ar(0, cnt) = fName 'ファイル名から取得した日付を配列に格納
            
            'CSVの中の12項目も配列に格納
            For c = LBound(SPcsvData) To UBound(SPcsvData)
                ReDim Preserve ar(12, cnt)
                ar(c + 1, cnt) = Mid(SPcsvData(c), 2, Len(SPcsvData(c)) - 2) 'データが""で囲われているので除去
            Next
                       
            cnt = cnt + 1
        Loop
    
        .Close 'ファイルを閉じる
        End With
        
            
    Next
    
    '何かデータが入っていた時の為に、一度セルのデータを消去
    Worksheets("data").Range("A1").CurrentRegion.ClearContents
    
    '読み込んだCSVファイルのデータを一気に書き出し
    Worksheets("data").Range("A1").Resize(UBound(ar, 2) + 1, UBound(ar, 1) + 1).Value = _
    Application.WorksheetFunction.Transpose(ar) 'Excel関数で行列入替
    
    Set file = Nothing
    Set files = Nothing
    Set fs = Nothing
    
End Sub

Function replaceColon(str As String) As String
    Dim strTemp As String
    Dim quotCount As Long
    Dim L As Long

    For L = 1 To Len(str)
        strTemp = Mid(str, L, 1) '1文字づつ調べる
        If strTemp = """" Then 'ダブルコーテーション(")を単なる記号として扱いたいときは「""」と2つ続けて書く。
            quotCount = quotCount + 1
        ElseIf strTemp = "," Then
            If quotCount Mod 2 = 0 Then
            str = Left(str, L - 1) & ":" & Right(str, Len(str) - L)
            End If
        End If
    Next

    replaceColon = str
End Function
 

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

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

2021-01-16 11:30:58 受講生さんからの投稿です。

小川先生

課題作成致しました。ほとんど何も見ずにできたことに感動しました。
荒削りかとは思いますが、添削願います。

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

[12827]テキストファイルの操作について

2021-01-15 12:24:59 たかちゃんさんからの投稿です。

気象庁のページから以下の条件で、CSVファイルをダウンロードし
時刻が9:00の行の日時と気温データを取得しグラフを作成する
マクロを作成してみました。
Excel2019で動作確認済み。

前準備
1.気象庁のページからCSVファイルをダウンロードする
場所:羽田と八戸
取得データ:気温
期間:2020/12/1~2020/12/31

2.以下のような名前をつけて、kion という名前のフォルダの中に入れておく
HanedaDec.csv
HachinoheDec.csv

マクロの動き
1.9:00の行のデータのみ取得。
2.配列に格納
3.CSVのファイル名のシートを作成し、データの書き出し&折れ線グラフを作成

CreateGrapthに関しては、自動記録で作成しました。

【参考URL】
http://it-benkyou.seesaa.net/article/435728508.html

Option Explicit
'Microsoft Scripting Runtime にチェックを入れる→FSO使用のため
Dim fName As String

 Sub CreateData()
    Dim fs As New Scripting.FileSystemObject
    Dim files As Scripting.files
    Dim file As Scripting.file
    Dim csvFile As Scripting.TextStream
    Dim csvData As String
    Dim SPcsvData As Variant
    Dim c As Long
    Dim cnt As Long
    Dim ar() As Variant '()がないと動かないので要注意!!!
    Dim Dstr As String
    Dim D As Date
    Dim path As String
    
    'CSVファイルは、kionフォルダ内にいれておく
    path = ThisWorkbook.path & "\kion"
    
    
    Set files = fs.GetFolder(path).files
    
    'kionフォルダ内、全てのCSVファイルについて処理
    For Each file In files
    
        Set csvFile = fs.OpenTextFile(file, IOMode:=ForReading)
        fName = fs.GetBaseName(file) 'シート名作成用にファイル名を取得
        
        cnt = 0 '配列で使うカウント用
        
        'CSVファイルを最後の行まで読む
        Do While csvFile.AtEndOfStream <> True
        
            '最初のヘッダー行と最終行の2021/1/1が入らないように、先頭4文字が2020の行と
            'いう条件を設定
            csvData = csvFile.Read(4) '行の先頭4文字をcsvDataに代入
            If csvData = "2020" Then
            '1度4文字を読んでいる為、4文字以降から読み始めるので4文字(2020)を付け足した
                csvData = "2020" & csvFile.ReadLine
                SPcsvData = Split(csvData, ",")
                Dstr = SPcsvData(0) '日時データを文字列として格納
                D = CDate(Dstr) 'CDate関数を使用して、文字列→Data型に変換
                
                '9:00のデータだけを取得し、配列に格納
                If Hour(D) = 9 Then
                    ReDim Preserve ar(1, cnt)
                    ar(0, cnt) = SPcsvData(0) '日時
                    ar(1, cnt) = SPcsvData(1) '気温(必要な日時と気温のデータのみ配列に格納)
                    cnt = cnt + 1
                End If
                
            Else
                csvFile.SkipLine
            End If
        Loop
        
        'グラフを作る為に、一度Excelに書き出す
        Dim Nws As Worksheet
    '    Worksheets.Add after:=Worksheets(Worksheets.Count)
        Set Nws = Worksheets.Add
        Nws.Name = fName
        
        For c = LBound(ar, 2) To UBound(ar, 2)
            Worksheets(fName).Range("A1").Offset(c).Value = ar(0, c)
            Worksheets(fName).Range("B1").Offset(c).Value = ar(1, c)
        Next
        
        CreateGraph
        '次の処理でも使うので配列の中を消しておく!
        Erase ar
    Next
    
    Set csvFile = Nothing
    Set file = Nothing
    Set files = Nothing
    Set fs = Nothing
    
End Sub

Private Sub CreateGraph()
'Excelの自動記録でグラフを作成
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ws.Range("A1").CurrentRegion.Select
    ws.Shapes.AddChart2(227, xlLineMarkers).Select
    ActiveChart.SetSourceData Source:=ws.Range("A1").CurrentRegion
    ActiveChart.Axes(xlCategory).Select
    ActiveChart.Axes(xlCategory).Select
    ActiveChart.Axes(xlCategory).CategoryType = xlCategoryScale
    ActiveChart.Axes(xlValue).Select
    ActiveChart.Axes(xlValue).MinimumScale = -15
    ActiveChart.Axes(xlValue).MaximumScale = 20
    ActiveChart.ChartTitle.Select
    ActiveChart.ChartTitle.Text = fName & "気温"

    With Selection.Format.TextFrame2.TextRange.Characters(1, 2).ParagraphFormat
        .TextDirection = msoTextDirectionLeftToRight
        .Alignment = msoAlignCenter
    End With
    With Selection.Format.TextFrame2.TextRange.Characters(1, 2).Font
        .BaselineOffset = 0
        .Bold = msoFalse
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = RGB(89, 89, 89)
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 14
        .Italic = msoFalse
        .Kerning = 12
        .Name = "+mn-lt"
        .UnderlineStyle = msoNoUnderline
        .Spacing = 0
        .Strike = msoNoStrike
    End With
   
End Sub

 

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

[12824]Left関数、Mid関数、Find関数を組み合わせる

2021-01-14 20:59:13 FUMIKAさんからの投稿です。

今まで関数はほとんど使っていなかったので、3つも覚えることが出来て楽しかったです。
FIND関数で使った、名字と名前の間にある「/」は例えば「 (スペース)」であっても使えるものでしょうか。

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

[12812]基礎講座第3章4 – Len関数、Instr関数

2021-01-13 16:04:52 受講生さんからの投稿です。

LenSample()で
Range(“A6”).Value = Len(Range(“A1”).Value)を
Range(“A6”).Value = Len(Range(“A1”))と
.Valueを省略しても良いでしょうか?
試してみたら答えは同じだったので。


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

[12806]ファイルの操作・フォルダの操作説明

2021-01-12 11:30:27 たかちゃんさんからの投稿です。

ファイルシステムオブジェクトを使用して、エクセルに写真を張り付け
工事現場の作業報告書のようなものを作成してみました。

事前準備:
エクセルでは”ひな形”という名前のシートを作成し、全てのセルの高さ20に設定。
写真の横にコメントを書ける罫線を引くなどしておく。

ひな形シートをコピーして、指定フォルダの写真を3枚貼り
再び、ひな形シートをコピーして、指定フォルダの残りの写真を
3枚づつ貼っていくマクロです。

Excel2019で動作確認済み。記念に投稿させて頂きました。


'Microsoft Scripting Runtimeにチェック→FSOを使用する為
Sub 画像貼り付け()
    Dim lngTop As Long 'TOPの余白用
    Dim fs As FileSystemObject
    Dim objFile As Scripting.File
    Dim objFldr As Scripting.Folder
    Dim c As Long '写真貼り付けのカウント用
    Dim cFiles As Long 'ファイルの数
    Dim cLast As Long  '最後の3の倍数用
    Dim ws As Worksheet  '作業用ワークシート
    
    Set fs = New Scripting.FileSystemObject
    Set objFldr = fs.GetFolder(ThisWorkbook.Path & "\写真")

    '最初は、写真を貼るシートをコピーする
    Worksheets("ひな形").Copy after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Format(Date, "yymmdd")
    Set ws = ActiveSheet
    
    c = 1 '写真を貼り付けるカウント用
    lngTop = 20 '写真貼の際、Topの余白を20の意味
    
    cFiles = objFldr.Files.Count 'フォルダの中のファイル数
    
    'A4 1枚に3枚づつ写真を貼り付ける。最後の3の倍数では
    'シート(ページ)を追加したくない為、ここで最後の3の倍数を確認
    If cFiles Mod 3 = 0 Then
        cLast = (cFiles \ 3) * 3
    End If
    
    '写真を貼り付け
    For Each objFile In objFldr.Files

        ws.Shapes.AddPicture _
            Filename:=objFile, _
            LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=20, _
            Top:=lngTop, _
            Width:=300, _
            Height:=200
        
        lngTop = lngTop + 200 + 20
        
        '3回写真を貼ったら、次のページ(シート)を作成
        '但し、最後の3の倍数ではページ(シート)を作成しない
        If c Mod 3 = 0 And c <> cLast Then
            Worksheets("ひな形").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Format(Date, "yymmdd") & "_" & c
            Set ws = ActiveSheet
            lngTop = 20
        End If
        
        c = c + 1
    Next
    
    Set objFile = Nothing
    Set objFldr = Nothing
    Set fs = Nothing
    
End Sub
 







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

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

2021-01-11 18:36:47 受講生さんからの投稿です。

お世話になります。課題を提出いたします。
何も見ずにやって2時間半掛かりました。
フィードバックを宜しくお願いいたします。

Option Explicit
Public Sub Denpyo_Sakusei() '「伝票作成」ボタンに割り当て
    No_Saiban
    Sort_Torihikisaki
    Denpyo_Copy
    Sort_No
    MsgBox "完了しました。"
End Sub
Public Sub Denpyo_Sakujo() '「伝票削除」ボタンに割り当て
    Sheet_Sakujo
    MsgBox "削除しました。"
End Sub
Private Sub Denpyo_Copy()
    Sheet_Sakujo
    Dim wsFm As Worksheet
    Dim wsTo As Worksheet
    Dim st As String
    Dim lnFm As Long
    Dim lnFmMx As Long
    Dim lnTo As Long
    Dim dt As Date
    
    Set wsFm = Worksheets("main")
    lnFmMx = wsFm.Range("B" & Rows.Count).End(xlUp).Row
            
    For lnFm = 2 To lnFmMx
        If st &lt;> wsFm.Range("B" & lnFm).Value Then
            If lnFm > 2 Then
                keisen
            End If
            st = wsFm.Range("B" & lnFm).Value
            Sheets("main1").Copy After:=Sheets(2)
            Set wsTo = Worksheets("main1 (2)")
            wsTo.Name = st
            lnTo = 16
        End If
        
        dt = wsFm.Range("C" & lnFm).Value
        wsTo.Range("B" & lnTo).Value = Format(dt, "yy")
        wsTo.Range("C" & lnTo).Value = Format(dt, "mm")
        wsTo.Range("D" & lnTo).Value = Format(dt, "dd")
        
        wsTo.Range("E" & lnTo).Value = wsFm.Range("D" & lnFm).Value
        wsTo.Range("F" & lnTo).Value = wsFm.Range("E" & lnFm).Value
        wsTo.Range("H" & lnTo).Value = wsFm.Range("F" & lnFm).Value
        
        If wsFm.Range("G" & lnFm).Value > 0 Then
            wsTo.Range("I" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("J" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        End If
        
        If lnTo = 16 Then
            wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("K" & lnTo).Value = wsTo.Range("K" & lnTo - 1).Value + wsFm.Range("G" & lnFm).Value
        End If
        lnTo = lnTo + 1
    Next
    keisen
    wsFm.Activate
End Sub

Public Sub Sheet_Sakujo()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Left(ws.Name, 4) &lt;> "main" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Private Sub No_Saiban()
    Dim ln As Long
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    Range("A1").Value = "No."
    For ln = 2 To lnMx
        Range("A" & ln).Value = ln
    Next
End Sub

Private Sub Sort_Torihikisaki()
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
        Key:=Range("B2:B317"), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Private Sub Sort_No()
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
        Key:=Range("A2:A317"), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select
End Sub

Private Sub keisen()
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    With Range("B16:K" & lnMx + 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 = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    End With
End Sub

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

[12771]基礎講座第1章11 – テストの方法

2021-01-06 16:29:47 受講生さんからの投稿です。

お世話になります。
F8の一行ずつマクロを確認することができません。
導入編でも質問したのですが、Windows10ではエクセルを開く度にセキュリティを確認すればF8キーで一行ずつ黄色に反転されると思っていたのですが、どうもそうではないようで、F8キーを二回連打すると全て入力されてしまうことも度々で、F8キーが機能している時とそうでない時があって、規則性も分かりません。何か原因があるのでしょうか?
またははPCの不具合でしょうか?

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

[12758]エクセルマクロVBA「Web連携」DOMを使った解析_基礎

2021-01-05 04:55:19 たかちゃんさんからの投稿です。

いつもありがとうございます。お忙しい中、すみません。一つ質問させて下さい。

以下のような作りのWebページのTableタグから、各地域のデータを取得したいと考えています。
但し、北海道は、THタグの見出しとSPANタグの件名の両方が”北海道”となっているため、
If文でTHタグの内容が”北海道”の時は、Debug.printで書き出さないと設定したのですが
何故かIf文が適用されない状況です。


HTMLの中身
&lt;TBODY>
&lt;TR>
 &lt;TH>北海道 &lt;/TH>
 &lt;TD>&lt;SPAN>北海道&lt;/SPAN> &lt;/TD>
&lt;/TR>

&lt;TR>
 &lt;TH>東北 &lt;/TH>
 &lt;TD>&lt;SPAN>青森県&lt;/SPAN>&lt;WBR>&lt;SPAN>秋田県&lt;/SPAN>…&lt;/TD>
&lt;/TR>

'以下に紹介するライブラリの参照設定をしてください
'Microsoft WinHTTP Services, version 5.1 -> HTTPリクエストをするため
'Microsoft HTML Object Library -> コンテンツのDOMを解析するため
'Microsoft Scrintping Runtime -> Dictionaryを使用するため
Sub GetArea()
    Dim url As String
    url = "https://www.sej.co.jp/products/area.html&quot;

    Dim xh As New WinHttp.WinHttpRequest
    xh.Open "GET", url, False
    xh.send
    
    Dim sCode As String
    sCode = xh.Status
    If sCode &lt;> 200 Then
        MsgBox "リクエストに失敗しました" &amp; vbNewLine &amp; sCode
    End If
    
    'htmlをDOMとして取得する。そのための変数を宣言。
    Dim oHTml As New MSHTML.HTMLDocument
    oHTml.body.innerHTML = xh.ResponseText 'htmlボディーをDOMとして取得
    
    Dim tr As MSHTML.HTMLHeadElement
    Dim spa As MSHTML.HTMLHeadElement
    Dim tiku As String
    
    For Each tr In oHTml.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
        tiku = tr.ChildNodes(0).innerText
        'TRタグ内の0番目の子要素(THタグ)内のデータを取得
        '北海道はSpanタグ内にもあるため、ここでは北海道の時はDebug.printしないようIf文追加
        'なぜかIf文が適用されない状況です。
        If tiku &lt;> "北海道" Then
            Debug.Print tiku
        End If
        
        'TRタグ内の1番目の子要素(TDタグ)内のSpanタグ内のデータを取得
        For Each spa In tr.ChildNodes(1).getElementsByTagName("span")
            Debug.Print spa.innerText
        Next
        
    Next
    
End Sub 

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

[12754]データ記入用ファイルを配布する-その2

2021-01-04 18:54:38 受講生さんからの投稿です。

いつもお世話になっております。
VBAについてはたいへん関心がありましたが、今までいくら学習しても自分でプログラムを作成するにはいたらず、むずかしいと諦めていました。
どこのホームページかわかりませんが、この講座を紹介しており受講してみたところ、先生の考え方やどこに注意するのかなどもわかり、動画から作成するまでの流れも理解でき、今では初級レベルの問題で時間はかかりますが、自分で考えて作成することができるようになりました。
この講座に出会えたことを感謝しています。
※一番うれしかったのはハナコのステップで、これまでプログラム作成にあたっては、初めから完成形を作ろうとしていたことに問題があったのだと気付くことができました。本当にありがとうございます。

今回の課題の中で一つ質問があります。
今回の課題の回答の中で下記のようなプログラムがあります。「Workbooks(filename).Sheets(“歳入”).Select」とはじめにシートを選択していますが、それ以降の構文で「Workbooks(filename).Sheets(“歳入”)」や「Workbooks(“全部1つ.xls”).Sheets(“部署情報”)」のようにセルを指定するにあたりシート名等をしっかり指定しているので、この構文はいらないのではないかと思い、「Workbooks(filename).Sheets(“歳入”).Select」をコメントにして実行してみたところ「実行時エラー1004 RangeクラスのSelectメソッドが失敗しました。」と表示されました。
その理由がわからないため、教えていただけますでしょうか。
        記

 Workbooks(filename).Sheets("歳出").Select
        For gyo = 41 To 2 Step -1
            If Workbooks(filename).Sheets("歳出").Range("C" & gyo).Value &lt;> Workbooks("全部1つ.xls").Sheets("部署情報").Range("C" & busho).Value Then
                Workbooks(filename).Sheets("歳出").Range("A" & gyo & ":F" & gyo).Select
                Selection.Delete Shift:=xlUp
            End If
        Next

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

[12753]エクセルマクロVBA「Web連携」DOMを使った解析_基礎

2021-01-04 04:20:41 たかちゃんさんからの投稿です。

課題に使う新たなデータを求めスクレイピングをした所、いつもの方法ではBodyが文字化けした為、ADODB.Streamを使用した文字化け対策に挑戦しました。以下の過去コメントを参照しコピペで作成。
備忘録として記念投稿します。
因みに、文字化けしたWebページは、文字コードが「utf-8」でした。

結局、取得したかった数字は全て画像データ?となっていたので、文字化け解消してもデータ取得は不可でした。。。

ADODB.stream使う際は、該当の文字をByte型の配列に入れて、
下にある手順で設定をすれば何とかなる所までは分かりました。(^^)
(Byte型で読み込ませて、設定後、テキスト型で出力。)

'必要なライブラリ:
'[1] Microsoft ActiveX Data Object x.x Library -> 文字コード変更のため(x.x の部分は一番大きいバージョンを選べばまず間違いなくOK)
'[2] Microsoft WinHTTP Services, version 5.1 -> HTTPリクエストをするため

Sub GetRequestSimple1()
    Dim url As String
    url = "ここにhttp://~のURLを記入&quot;

    Dim xh As New WinHttp.WinHttpRequest 'HTTPリクエストを制御するクラスのインスタンスを生成
    xh.Open "GET", url, False
    xh.send
    
    Dim sCode As String
    sCode = xh.Status
    If sCode &lt;> 200 Then 'ステータスコードを調べる
        MsgBox "リクエストに失敗しました" & vbNewLine & sCode
    End If
    
    '普通にボディを取ってくると何故か文字化けする為、ADODB.Streamで文字化け対策
    '因みに上記のWebページの文字コードはutf-8
    '1.ボディを取ってきて、Byte型の配列に入れる
    Dim get_body() As Byte
    get_body = xh.ResponseBody
    
    
    Dim msg1 As String
    Dim msg2 As String
    msg1 = get_body 'Byte()を文字列に変換(msg1 as string だから)
    MsgBox msg1
    
    
    '2.ADODB.streamで、文字化け対策
    Dim ado_stream As New ADODB.Stream
    
    ado_stream.Open
    ado_stream.Position = 0
    ado_stream.Type = 1
    ado_stream.Write get_body
    
    ado_stream.Position = 0
    ado_stream.Type = 2
    ado_stream.Charset = "utf-8"
    msg2 = ado_stream.ReadText
    ado_stream.Close
    
    MsgBox msg2
    
    Range("B2").Value = msg2
    
End Sub
 

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

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

2021-01-03 19:51:29 らりおさんからの投稿です。

[宿題] お世話になっております。前回時(第9回)とは別に、もう一度イチから作成しました。追加課題の題意に正しく沿ったものができているかどうかも含めて添削お願い致します。

Option Explicit
Dim wM As Worksheet
Dim wM1 As Worksheet
Dim wAc As Worksheet
Dim w As Worksheet

Dim moTo As Long
Dim saKi As Long
Dim saiGo As Long
Dim Kingaku As Long

Dim HiDuke As Date

Sub denpyosakusei()
    Set wM = Workbooks("s09_homework.xls").Worksheets("main")
    Set wM1 = Workbooks("s09_homework.xls").Worksheets("main1")
    saiGo = wM.Range("B" & wM.Rows.Count).End(xlUp).Row
    
    syokyo
    main1_kairyo
    No
    wM.Range("A1:G" & saiGo).Sort key1:=wM.Range("B1"), Order1:=xlAscending, Header:=xlYes 'B列で並べ替え
    
    For moTo = 2 To saiGo
        HiDuke = wM.Range("C" & moTo).Value
        If wM.Range("B" & moTo).Value &lt;> wM.Range("B" & moTo - 1).Value Then
            saKi = 0
            Kingaku = 0
            wM1.Copy after:=wM
            Set wAc = ActiveSheet
            wAc.Name = wM.Range("B" & moTo).Value
        End If
        With wAc.Range("B16")
            .Offset(saKi).Value = Mid(Year(HiDuke), 3)
            .Offset(saKi, 1).Value = Month(HiDuke)
            .Offset(saKi, 2).Value = Day(HiDuke)
            .Offset(saKi, 3).Value = wM.Range("D" & moTo).Value
            .Offset(saKi, 4).Value = wM.Range("E" & moTo).Value
            .Offset(saKi, 6).Value = wM.Range("F" & moTo).Value
            Select Case wM.Range("G" & moTo).Value
                Case Is > 0
                    .Offset(saKi, 7).Value = wM.Range("G" & moTo).Value
                Case Else
                    .Offset(saKi, 8).Value = wM.Range("G" & moTo).Value
            End Select
            Kingaku = Kingaku + wM.Range("G" & moTo).Value
            .Offset(saKi, 9).Value = Kingaku
        End With
        saKi = saKi + 1
        If wM.Range("B" & moTo).Value &lt;> wM.Range("B" & moTo + 1).Value Then
            With wAc.Range("B16:K" & saKi + 16) '掛線
                .Borders(xlEdgeLeft).Weight = xlThin
                .Borders(xlEdgeBottom).Weight = xlThin
                .Borders(xlEdgeRight).Weight = xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .Borders(xlInsideHorizontal).LineStyle = xlDash
            End With
            wAc.PageSetup.PrintArea = "$A:$M$" & saKi + 16 '印刷範囲を最終行+1行まで指定
        End If
    Next
    
    No_syokyo
End Sub
Sub main1_kairyo() '追加[1]部分。ヘッダー、フッターをつけて印刷の向きを横に
    With wM1.PageSetup
        .CenterHeader = "&A" 'シート名
        .CenterFooter = "&P" 'ページ数
        .Orientation = xlPortrait
    End With

End Sub

Sub No() 'A列作成
    wM.Range("A2").FormulaR1C1 = "1"
    wM.Range("A3").FormulaR1C1 = "2"
    wM.Range("A2:A3").AutoFill Destination:=wM.Range("A2:A" & saiGo)
    With wM.Range("A1")
        .FormulaR1C1 = "No."
        .Font.Bold = True
        .Interior.ThemeColor = xlThemeColorAccent1
        .Interior.TintAndShade = 0.799981688894314
    End With
End Sub

Sub No_syokyo() '課題[2]部分のA列並べ替え&消去
    With wM
        .Range("A1:G" & saiGo).Sort key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
        .Range("A1:A" & saiGo).ClearContents
        .Range("A1").Interior.Pattern = xlNone
        .Range("A1").Font.Bold = False
        .Activate
    End With
End Sub

Sub syokyo()
    Application.DisplayAlerts = False
    For Each w In Worksheets
        If InStr(w.Name, "main") = 0 Then
            w.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

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

[12746]条件に一致するデータを別表に転記する。AutoFilterより便利な条件抽出マクロ。

2021-01-03 17:10:05 受講生さんからの投稿です。

とても難しいです。動画4・動画5はマクロコードの構成を暗記する勉強方法で大丈夫でしょうか。正直分解してもすんなり頭に入ってきません。

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

[12741]文字列を加工してデータ転記する(その2)

2021-01-03 05:12:06 ゲストさんからの投稿です。

小川様

お世話になっております。こちらの動画の後半で解説されていた路線駅名の処理について質問がございます。私はこのようにプログラムを書いて処理し、設問で指示された回答は出せたので問題ないと思うのですが、小川さんがこの方法を動画で取り上げなかった理由を教えてもらえないでしょうか?

 If ku = 0 Then
            ku = InStr(roseneki, "ル")
        End If


過去のコメントでは、「「手順書としてどうか?」という問いですね。」という回答が小川さんから出されてました。他の人がプログラムをメンテナンスする時に分かりにくいから、という理解でよろしいでしょうか。ご回答宜しくお願い致します。

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

[12735]基礎講座第1章12 – ドリル

2021-01-02 03:35:01 受講生さんからの投稿です。

すみません簡単な質問で、コピー貼り付けですがホーム+↓でというのが
わかりません。先生がされている方が速いので教えてください

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

[12726]基礎講座第1章11 – テストの方法

2020-12-30 21:15:52 受講生さんからの投稿です。


小川先生

初めて質問します。質問の回答は登録したメールに返信されるのでしょうか。基礎講座第1章11の質問に対し回答されるのでしょうか。質問・回答のやり取り方法を教えて下さい。

もう1点質問です。
標準モジュールの表記について教えて下さい。
テキストではSheetオブジェクト?と標準モジュールと階層がわかれて表記されていますが私のPCでは並列に表記されています。
並列に表記されても問題ないでしょうか?バージョンの問題でしょうか?ファイルも添付してます。

ご多忙の所恐縮ですがご教授下さい。

江副

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

[12724]エクセルマクロVBA「Web連携」DOMを使った解析_基礎

2020-12-30 05:21:56 たかちゃんさんからの投稿です。

セブンイレブンのおにぎり紹介ページより、おにぎりの名前を取得することに成功しました。

企業のWebページの作りは複雑すぎて、ブラウザからHTMLを確認した時は、もう読めないと思いました。(T_T)
しかし、一度Bodyの部分を、このコースで使っているマクロを使ってExcelに取り込んで、更にメモ帳にはりつけて
全体を眺めたら、商品名を発見し、このページに関してはなんとかその部分だけは仕組みが分かったかなという感じです。
例題のプログラムを再利用して、ちょこっと書き直しただけですが、、動いた時は本当に嬉しかったです。(^^)

HTMLの中身はこんな感じ。
&lt;div class=””list-inner-~~~””>
&lt;figure> 写真
&lt;div class=””detail””>
&lt;div class=””item_ttl””>  商品のおにぎりの名前
&lt;div class=””item_price””>  価格
&lt;div class=””item_region””> 販売地域

'以下に紹介するライブラリの参照設定をしてください
'Microsoft WinHTTP Services, version 5.1 -> HTTPリクエストをするため
'Microsoft HTML Object Library -> コンテンツのDOMを解析するため
Sub GetRequestSimple1()
    Dim url As String
    url = "https://www.sej.co.jp/products/a/onigiri/&quot;

    Dim xh As New WinHttp.WinHttpRequest
    xh.Open "GET", url, False
    xh.send
    
    Dim sCode As String
    sCode = xh.Status
    If sCode &lt;> 200 Then
        MsgBox "リクエストに失敗しました" & vbNewLine & sCode
    End If
    
    'htmlをDOMとして取得する。そのための変数を宣言。
    Dim oHTml As New MSHTML.HTMLDocument
    oHTml.body.innerHTML = xh.ResponseText 'htmlボディーをDOMとして取得
    
    'oH2--> 1つのおにぎり紹介のdiv(この中に、商品名や値段の情報が記載)
    'oH3-->商品名のdiv
    Dim oH2 As MSHTML.HTMLHeadElement
    Dim oH3 As MSHTML.HTMLHeadElement
    For Each oH2 In oHTml.getElementsByClassName("list_inner")
        For Each oH3 In oH2.getElementsByClassName("item_ttl")
            Debug.Print oH3.innerText '商品名(おにぎり名)を書き出し
        Next
    Next
End Sub
 

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

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

2020-12-27 15:40:45 加藤さんからの投稿です。

予習ではこのように書きました。
自動記録コードの編集に課題がありそうですが、解説を楽しみに拝見いたします。

 Sub yoshu8()
    Dim sh As Worksheet
    Set sh = Worksheets("main")
    Dim gyo As Long
    Dim gyomx As Long
    gyomx = sh.Range("B65536").End(xlUp).Row
    For gyo = 2 To gyomx
        sh.Range("A" & gyo).Value = gyo - 1
    Next
    Selection.AutoFilter
    sh.AutoFilter.Sort.SortFields.Clear
    sh.AutoFilter.Sort.SortFields.Add2 Key:=Range( _
        "B1:B317"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With sh.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    sh.AutoFilter.Sort.SortFields.Clear
    sh.AutoFilter.Sort.SortFields.Add2 Key:=Range( _
        "A1:A317"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
        sh.AutoFilter.Sort.SortFields.Clear
    sh.AutoFilter.Sort.SortFields.Add2 Key:=Range( _
        "A1:A317"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With sh.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub 

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

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

2020-12-26 01:42:34 加藤さんからの投稿です。

予習のコードです。
メールを読むのはこれからですが、H列に合計を入れるところや罫線は、もっと効率の良い方法があるのではと楽しみです。

Sub day7yoshu()
    Delete_Sheets
    Dim shFm As Worksheet
    Dim InFm As Long
    Dim InFmMx As Long
    Dim st As String
    Dim shTo As Worksheet
    Dim dt As Date
    Dim gyo As Long
    Set shFm = Worksheets("main")
    InFmMx = shFm.Range("B65536").End(xlUp).Row
    For InFm = 2 To InFmMx
        If st &lt;> shFm.Range("B" & InFm).Value Then
            Debug.Print shFm.Range("B" & InFm).Value
            st = shFm.Range("B" & InFm).Value
            Sheets("main1").Copy After:=Sheets(2)
            Set shTo = ActiveSheet
            shTo.Name = st
            gyo = 16
        End If
        If shFm.Range("G" & InFm).Value &lt; 0 Then
            '貸方に負の数が入らないよう、右辺はマイナスとした。
            shTo.Range("J" & gyo).Value = -shFm.Range("G" & InFm).Value
        Else
            shTo.Range("I" & gyo).Value = shFm.Range("G" & InFm).Value
        End If
        dt = shFm.Range("C" & InFm).Value
        shTo.Range("H" & gyo).Value = shFm.Range("F" & InFm).Value
        shTo.Range("E" & gyo).Value = shFm.Range("D" & InFm).Value
        shTo.Range("F" & gyo).Value = shFm.Range("E" & InFm).Value
        shTo.Range("B" & gyo).Value = Right(Year(dt), 2)
        shTo.Range("C" & gyo).Value = Month(dt)
        shTo.Range("D" & gyo).Value = Day(dt)
        If gyo = 16 Then
            shTo.Range("K" & gyo).Value = shTo.Range("I" & gyo).Value - shTo.Range("J" & gyo).Value
        ElseIf gyo > 16 Then
            shTo.Range("K" & gyo).Value = shTo.Range("I" & gyo).Value - shTo.Range("J" & gyo).Value + shTo.Range("K" & gyo - 1).Value
        End If
        shTo.Range("B" & gyo & ":K" & gyo).Select
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        gyo = gyo + 1
    Next
End Sub

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

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

[12700]Excel の表を貼り付けるには

2020-12-24 03:04:53 たかちゃんさんからの投稿です。

47都道府県の性別・年代別の人口比率についてドーナツグラフを作成し、
パワーポイントにスライドに一気に張り付けるものを作成してみました。

このアイデアは以下の参考サイトからですが、コードは全て自力で書き上げました。(^^)
【参考サイト】
https://coconala.com/blogs/1312355/25743

パワーポイントは、色んな所に似たようなプロパティがあって苦労しました。
各プロパティの場所が分かるように、あえて纏めず書いているのでスッキリしていませんが
記念に投稿します。(Excel 2019動作確認済み)

Sub PowerPointTest()
    Dim ppApp As PowerPoint.Application
    Dim ppPrt As PowerPoint.Presentation
    Dim ppSld As PowerPoint.Slide
    Dim ppShape As PowerPoint.Shape 'グラフのタイトルを入力するシェイプ用
    Dim todoufuken As String
    Dim gyo As Long
    
    'Presentation1.pptxを開く(スライドが0枚の状態)
    Set ppApp = New PowerPoint.Application
    Dim path As String
    path = ThisWorkbook.path & "\Presentation1.pptx"
    ppApp.Visible = True
    Set ppPrt = ppApp.Presentations.Open(Filename:=path, ReadOnly:=msoFalse)
    
    
    For gyo = 3 To 49
    
    Worksheets("form").Range("A3").Value = Worksheets("data").Range("A" & gyo).Value
    
    'グラフのタイトル名
    todoufuken = Worksheets("form").Range("B3").Value

    'Excelでグラフを作成する為に範囲を選択、グラフ作成
    Worksheets("form").Range("C1:J3").Select
    Worksheets("form").Shapes.AddChart2(381, xlSunburst).Select

    'グラフのタイトルを非表示
    Worksheets("form").ChartObjects(1).Chart.HasTitle = False
    
    'グラフサイズを調整(ここで調整しないとグラフのデータラベル表示が欠けてしまう)
    Debug.Print Worksheets("form").ChartObjects(1).Chart.PlotArea.Height
    Debug.Print Worksheets("form").ChartObjects(1).Chart.PlotArea.Width
    
    Worksheets("form").ChartObjects(1).Height = 252.262504577637
    Worksheets("form").ChartObjects(1).Width = 407.325050354004
    
    Debug.Print Worksheets("form").ChartObjects(1).Chart.PlotArea.Height
    Debug.Print Worksheets("form").ChartObjects(1).Chart.PlotArea.Width
    
    'グラフをコピー(画像として)
    Worksheets("form").ChartObjects(1).CopyPicture appearance:=xlScreen, Format:=xlPicture

    'グラフを消去(要らないのでグラフは削除しておく)
    Worksheets("form").ChartObjects(1).Delete

    'スライドを作成し、グラフの大きさを調整しスライドの中央に貼り付け
    Dim c As Long    'スライドのカウント用
  
    'スライドの追加
    c = ppPrt.Slides.Count
    Set ppSld = ppPrt.Slides.Add(Index:=c + 1, Layout:=ppLayoutBlank)
    
    'グラフ(シェイプ)の貼り付け
    ppSld.Shapes.Paste
    
    'シェイプの大きさを設定(拡大)
    ppSld.Shapes(1).LockAspectRatio = msoCTrue
    ppSld.Shapes(1).Width = 800
'
    'シェイプの大きさを調査
    Debug.Print ppSld.Shapes(1).Name
    Debug.Print ppSld.Shapes(1).Width
    Debug.Print ppSld.Shapes(1).Height
    
    'スライドの大きさを調査
    Debug.Print ppPrt.PageSetup.SlideWidth
    Debug.Print ppPrt.PageSetup.SlideHeight
    
    'シェイプを中央揃え
    ppSld.Shapes(1).Left = (ppPrt.PageSetup.SlideWidth - ppSld.Shapes(1).Width) / 2
    ppSld.Shapes(1).Top = (ppPrt.PageSetup.SlideHeight - ppSld.Shapes(1).Height) / 2
  
    'グラフのタイトルを入力する為、シェイプを作成し文字を入力
    ppSld.Shapes.AddShape Type:=msoShapeRectangle, Left:=20, Top:=20, Width:=300, Height:=100
    
    Set ppShape = ppSld.Shapes(2)
    ppShape.Fill.Visible = msoFalse
    ppShape.Line.Visible = msoFalse
    ppShape.TextFrame.TextRange.Characters.Font.Size = 60
    ppShape.TextFrame.TextRange.Characters.Font.Color = vbBlack
'   日本語のフォントを設定するので、NameFarEastを使用。"HG 丸ゴシック M-PRO"は何故か使えない為明朝体を使用。
    ppShape.TextFrame.TextRange.Font.NameFarEast = "MS 明朝"
    ppShape.TextFrame.TextRange.Text = todoufuken
    
    Next
    
    ppPrt.Save
    ppPrt.Close
    ppApp.Quit
    
    Set ppShape = Nothing
    Set ppSld = Nothing
    Set ppPrt = Nothing
    Set ppApp = Nothing

End Sub
 


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

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

2020-12-24 00:24:44 加藤さんからの投稿です。

予習段階で作成したコードです。

よく迷うのですが、変数の名前はどんな点を考慮して付ければよいでしょうか。他のところで説明されていましたらすみません。

一応、ハンガリアン記法の動画は拝見しました。

  Sub day6yoshu()
    Delete_Sheets
    Dim shFm As Worksheet
    Dim InFm As Long
    Dim InFmMx As Long
    Dim st As String
    Dim shTo As Worksheet
    Dim dt As Date
    Dim gyo As Long
    Set shFm = Worksheets("main")
    InFmMx = shFm.Range("B65536").End(xlUp).Row
    For InFm = 2 To InFmMx
        If st &lt;> shFm.Range("B" & InFm).Value Then
            Debug.Print shFm.Range("B" & InFm).Value
            st = shFm.Range("B" & InFm).Value
            Sheets("main1").Copy After:=Sheets(2)
            Set shTo = ActiveSheet
            shTo.Name = st
            gyo = 16
        End If
        If shFm.Range("G" & InFm).Value &lt; 0 Then
            shTo.Range("J" & gyo).Value = shFm.Range("G" & InFm).Value
        Else
            shTo.Range("I" & gyo).Value = shFm.Range("G" & InFm).Value
        End If
        dt = shFm.Range("C" & InFm).Value
        shTo.Range("H" & gyo).Value = shFm.Range("F" & InFm).Value
        shTo.Range("E" & gyo).Value = shFm.Range("D" & InFm).Value
        shTo.Range("F" & gyo).Value = shFm.Range("E" & InFm).Value
        shTo.Range("B" & gyo).Value = Right(Year(dt), 2)
        shTo.Range("C" & gyo).Value = Month(dt)
        shTo.Range("D" & gyo).Value = Day(dt)
        gyo = gyo + 1
    Next
End Sub


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

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

[12694]商品ごと、年ごとの販売額合計をピボットテーブルのように出力する(その2-2)

2020-12-22 23:20:32 受講生さんからの投稿です。

小川塾長

いつもお世話になっております。
ご教授いただけましでしょうか?

IF hida>2 then ですが、なぜこのコードが必要なのかが理解できません。
最初のループでshohinがempty値だからでしょうか?

それに伴い、Range(“B”&hida-1).value=2005 thenで、なぜ-1するのかも理解ができずにおります。

どうぞ宜しくお願い致します。

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

[12688]PowerPoint の主要オブジェクト紹介

2020-12-22 02:35:03 たかちゃんさんからの投稿です。

パワーポイントと連携させて英単語帳のようなものを作成するマクロを
書いてみましたので、記念に投稿します!(^o^)

①Presentation1.pptxというファイルを作成(スライドは0枚)し、
 マクロが書かれたエクセルと同じフォルダに入れておく。
②ExceのA列に英単語、B列に和訳が記入されている状態で、マクロを実行。
③PowerPointにて、スライドを1枚作成し、英単語を入力。
 スライドを1枚作成し、和訳を入力。
Excel2019にて動作確認済み。

Sub PowerPointSlideAdd()
    Dim ppApp As PowerPoint.Application
    Dim ppPrt As PowerPoint.Presentation
    Dim ppSld As PowerPoint.Slide
    Dim ppShape As PowerPoint.Shape
    
    'Presentation1.pptxを開く(スライドが0枚の状態)
    Set ppApp = New PowerPoint.Application
    Dim path As String
    path = ThisWorkbook.path & "\Presentation1.pptx"
    ppApp.Visible = True
    Set ppPrt = ppApp.Presentations.Open(Filename:=path, ReadOnly:=msoFalse)
    
    
    
    Dim c As Long    'スライドのカウント用
    Dim gyo As Long  'エクセルのデータ取得用
    
    For gyo = 2 To Range("B" & Rows.Count).End(xlUp).Row
    
        '英単語を入力
        '1番後ろにスライドを追加
        c = ppPrt.Slides.Count
        Set ppSld = ppPrt.Slides.Add(Index:=c + 1, Layout:=ppLayoutBlank)
        '文字を入力する為、シェイプを1つ作成
        ppSld.Shapes.AddShape Type:=msoShapeRectangle, Left:=20, Top:=160, Width:=920, Height:=164
        '作成したシェイプをへ書式を整えて、データを入力
        Set ppShape = ppSld.Shapes(1)
        With ppShape
            .Fill.Visible = msoFalse
            .Line.Visible = msoFalse
            With .TextFrame.TextRange
                .Font.Size = 160
                .Font.Color = vbBlack
                .Font.Name = "MS ゴシック"
                .Text = Range("A" & gyo).Value
            End With
        End With
        
        
        '日本語の単語を入力
        '一番後ろにスライドを追加
        c = ppPrt.Slides.Count
        Set ppSld = ppPrt.Slides.Add(Index:=c + 1, Layout:=ppLayoutBlank)
        '文字を入力する為、シェイプを1つ作成
        ppSld.Shapes.AddShape Type:=msoShapeRectangle, Left:=20, Top:=160, Width:=920, Height:=164
        '作成したシェイプにエクセルの値を入力
        Set ppShape = ppSld.Shapes(1)
        With ppShape
            .Fill.Visible = msoFalse
            .Line.Visible = msoFalse
            With .TextFrame.TextRange
                .Font.Size = 160
                .Font.Color = vbBlack
                '日本語のフォントを設定するので、NameFarEastを使用
                .Font.NameFarEast = "MS ゴシック"
                .Text = Range("B" & gyo).Value
            End With
        End With
    
    Next
    
    ppPrt.Save
    ppPrt.Close
    ppApp.Quit
    
    Set ppShape = Nothing
    Set ppSld = Nothing
    Set ppPrt = Nothing
    Set ppApp = Nothing
End Sub
 


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

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

2020-12-21 23:51:05 加藤さんからの投稿です。

4日目を終えて予習で書いたコードです。

発展編のフォローアップを進めていると、基礎編及び基礎編のフォローアップで学んだことがすごく効いていて、発展編1はまさに基礎編の応用なのだと実感しております。
5日目のメールは追って確認させていただきます。今後も楽しみにしております。

Sub day4yoshu()
    Delete_Sheets
    Dim shFm As Worksheet
    Dim InFm As Long
    Dim InFmx As Long
    Dim st As String
    Dim shTo As Worksheet
    Set shFm = Worksheets("main")
    InFmx = Range("B65536").End(xlUp).Row
    For InFm = 2 To InFmx
        If shFm.Range("B" & InFm).Value <> shFm.Range("B" & InFm - 1).Value Then
            Debug.Print shFm.Range("B" & InFm).Value
            st = shFm.Range("B" & InFm).Value
            Sheets("main1").Copy After:=Sheets(2)
            Set shTo = ActiveSheet
            shTo.Name = st
        End If
    Next
End Sub 


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

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

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

2020-12-20 12:48:26 受講生さんからの投稿です。

何とかこの回まではできました。次回の予習も行います。

前回の予習では、私はIf文にAndで”main”と”main2″を設定しましたが、

解説のIf Left(sh.Name, 4) &lt;> “main” Then
はスマートですね。

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

[12678]エクセルマクロ・VBAを利用するための推奨設定 – Excel2007の場合

2020-12-12 13:22:21 受講生さんからの投稿です。

ファイル形式が .xlsmであっても、マクロが入ってない場合もあるということですね。先入観に囚われていたのが小さな気づきが得られました。
ちょっと実験してみたところ.xlsmの方が.xlsxに比べ10バイトほど大きかったです。
これからもよろしくお願いします。

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

[12673]補講:複数ファイル間でのデータ転記

2020-12-10 13:40:05 ゲストさんからの投稿です。

小川様

動画の作成ありがとうございました。
今後自分が作成したいプログラムが、異なるファイル間でのデータ転記システムなので、非常に参考となる講義でした。

質問がございます。
今回はフォルダ内に保存したファイル名が一定の場合のみに有効なプログラムであると思いますが、ファイル名が転記作業毎に変わる(別のファイルになる)場合のプログラムはどうすればよいでしょうか?転記作業の度にVBAのファイル名を変更するのは現実的ではないですよね。

この講義を受けて、自分が思い描くプログラムを実現するための課題が明確になりました。自分に不足している知識を積み重ねていきたいので、アドバイスを頂戴したいです。

私が実現したいプログラムは以下の通りです
①会社規定の製品情報が記載されたデータ転記元のExcelファイルがある
②_①のファイルは製品毎に用意されており200~300種類ほどある
③転記元のファイルからデータをユーザーから指示されるExcelファイルに転記する。書式貼りつけでなく、値貼りつけもしくは数式貼りつけが指示されている
④_③の理由から転記先のフォーマットが一定でないのでマクロで完全自動化するのが困難

転記元と転記先のファイル名の識別と作業実行が課題になっております。

私が実現したいプログラムのイメージをファイルで添付致しますのでご確認をお願い致します。

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

[12660]簡単なマクロを書いてみる – 基本編

2020-12-01 15:20:36 受講生さんからの投稿です。

こんにちは。とても丁寧な解説で私でもついていけることに感謝いたします。しかし、やはり私も【F8】で壁にあたりました。機能しません。【F8】最初の行で全て入力されてしまいます。マウス操作で 「デバッグ」→「ステップイン」でも同じで[Fn]キーを押しながら[F8]は私のPCではミュートです。
ちなみにこのまま講座を先に進んで自動記録機能では【F8】は一行ずつ機能しました。
PCを変えてWindows7では機能したのですがWindows10では機能しません。これはPCに原因があると考えられますか?いかがでしょうか?宜しくお願いいたします。

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


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

 

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

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

トップへ