- 締切済み
下記のマクロをもっと早くするには？
下記のマクロは、 A列にあるURLがSSL化（https）されているかを調べるものです。 このマクロを動かすと、大体３秒に１つのURLを調べるくらいの早さです。 もっと早く調べられるようにするには、どのような記述にすればできるでしょうか？ また、エクセルの他の設定で、マクロを早くできたりしますか？ よろしくお願いいたします。 Sub SSL() Dim objHttp As Object Dim nURL As String Dim strURL As String Dim i As Long, f As String, l As String Dim Lastrow As Long, getLine As Long Set objHttp = CreateObject("WinHttp.WinHttpRequest.5.1") On Error GoTo ErrHandler 'A1から getLine = Cells(Rows.Count, 2).End(xlUp).Row Lastrow = Cells(Rows.Count, 1).End(xlUp).Row If getLine = Lastrow Then MsgBox "既に終わっているか、データがないです。", vbExclamation: Exit Sub If getLine < Lastrow And Cells(1, 2).Value <> "" Then getLine = getLine + 1 Else getLine = 1 '最初の行が1行目からの場合 End If For i = getLine To Lastrow strURL = LCase(Trim(Cells(i, 1).Value)) 'A列の登録URL strURL = Replace(strURL, "https:", "http:") If strURL Like "http*" Then objHttp.Open "GET", strURL, False objHttp.send DoEvents 'ESC割り込み可能にする With objHttp If .Status = 200 Then nURL = .Option(1) 'WinHttpRequestOption_URL f = Mid(strURL, 1, InStr(strURL, "://")) l = Mid(nURL, 1, InStr(nURL, "://")) If nURL = "" Then Cells(i, 2).Value = "no URL" ElseIf nURL <> "" Then If LCase(f) = LCase(l) Then Cells(i, 2).Value = "non SSL" Else Cells(i, 2).Value = "https" End If End If Else Cells(i, 2).Value = "Err:" & .Status End If End With End If Endline: nURL = "" strURL = "" Next i MsgBox "Finished" Exit Sub ErrHandler: If Err() <> 0 Then Cells(i, 2).Value = Err.Number 'マイナスになるのは外部エラー GoTo Endline End If End Sub
- mute_low
- お礼率2% (55/2075)
- Visual Basic
- 回答数3
- ありがとう数0
- みんなの回答 （3）
- 専門家の回答
みんなの回答
- superside0
- ベストアンサー率64% (452/700)
関連するQ&A
- １つのPCで同じマクロを複数動かす
下記のマクロは、 A列にあるURLがSSL化（https）されているかを調べるものです。 このマクロで、いろんなURLを調べる作業があります。 その作業を早く完了させるために、下記のマクロを同時に動かそうと思っています。 しかし、エクセルを使えるPCが１つしかありません。 エクセルを２つ起動して、調べるURLを分けて、 ２つのエクセルでマクロを同時に動かす。 これをやろうと思いましたが、かなりPCが重くなるし、 エクセルが度々フリーズしたみたいになります。 どうにか、１つのPCで下記のマクロを複数動かして、 いろんなURLを調べる作業を、早くに完了する方法はありますでしょうか？ エクセル2016です。 よろしくお願いいたします。 Sub SSL() Dim objHttp As Object Dim nURL As String Dim strURL As String Dim i As Long, f As String, l As String Dim Lastrow As Long, getLine As Long Set objHttp = CreateObject("WinHttp.WinHttpRequest.5.1") On Error GoTo ErrHandler 'A1から getLine = Cells(Rows.Count, 2).End(xlUp).Row Lastrow = Cells(Rows.Count, 1).End(xlUp).Row If getLine = Lastrow Then MsgBox "既に終わっているか、データがないです。", vbExclamation: Exit Sub If getLine < Lastrow And Cells(1, 2).Value <> "" Then getLine = getLine + 1 Else getLine = 1 '最初の行が1行目からの場合 End If For i = getLine To Lastrow strURL = LCase(Trim(Cells(i, 1).Value)) 'A列の登録URL strURL = Replace(strURL, "https:", "http:") If strURL Like "http*" Then objHttp.Open "GET", strURL, False objHttp.send DoEvents 'ESC割り込み可能にする With objHttp If .Status = 200 Then nURL = .Option(1) 'WinHttpRequestOption_URL f = Mid(strURL, 1, InStr(strURL, "://")) l = Mid(nURL, 1, InStr(nURL, "://")) If nURL = "" Then Cells(i, 2).Value = "no URL" ElseIf nURL <> "" Then If LCase(f) = LCase(l) Then Cells(i, 2).Value = "non SSL" Else Cells(i, 2).Value = "https" End If End If Else Cells(i, 2).Value = "Err:" & .Status End If End With End If Endline: nURL = "" strURL = "" Next i MsgBox "Finished" Exit Sub ErrHandler: If Err() <> 0 Then Cells(i, 2).Value = Err.Number 'マイナスになるのは外部エラー GoTo Endline End If End Sub
- 締切済み
- Visual Basic
- マクロ 入力する文字に色を付けたい
Sub CountUp(ByVal mCol1 As String, mCol2 As String) Dim LastRow1 As Long Dim LastRow2 As Long Dim mRow As Long With Sheets("プレーヤー") LastRow1 = .Cells(Rows.Count, mCol1).End(xlUp).Row LastRow2 = .Cells(Rows.Count, mCol2).End(xlUp).Row If LastRow1 > LastRow2 Then mRow = LastRow1 Else mRow = LastRow2 End If If LastRow1 = 1 Then LastRow1 = 2 End If .Cells(mRow + 1, mCol1).Value = .Cells(LastRow1, mCol1) + 1 End With End Sub このコードに文字の色の指定をしたいです Selection.Font.ColorIndex = 3を入れたら赤色文字で入力できるかなと思ったのですがうまくいきませんでした（エラーにはならないのですが、色が付かなかったです）
- ベストアンサー
- Excel（エクセル）
- エクセル マクロ チェックボックス
sheet1にチェックボックスが３つあり、マクロを実行するコマンドボタンが１つあります。 チェックボックスにレ点を入れることにより、sheet4のデータからsheet2にグラフを作成しようと考えてますが、エラーが出てしまい解決できません。 どのように訂正したらいいのか教えて頂けないでしょうか。 Private Sub CommandButton1_Click() Dim GraphRange As String Dim Graph As ChartObject Dim lastRow As Long Set Graph = Sheets("sheet2").ChartObjects.Add(150, 27, 350, 200) lastRow = Sheets("sheet4").Range("A" & Rows.Count).End(xlUp).Row GraphRange = Sheets("sheet4").Range(Cells(1, 1), Cells(lastRow, 1)).Value If Sheets("sheet1").CheckBox1.Value = True Then 'CheckBox1にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 2), Cells(lastRow, 2)).Value End If If Sheets("sheet1").CheckBox2.Value = True Then 'CheckBox2にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 3), Cells(lastRow, 3)).Value End If If CheckBox3.Value = True Then 'CheckBox3にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 4), Cells(lastRow, 4)).Value End If Graph.Chart.ChartWizard Source:=Sheets("sheet4").Range(GraphRange).Value, _ Gallery:=xlLine, Format:=1, PlotBy:=xlColumns, _ CategoryLabels:=1, SeriesLabels:=1, HasLegend:=True End Sub
- ベストアンサー
- オフィス系ソフト
- マクロエラー処理
下記のマクロを実行すると、If (.Range のところでコンパイルエラー参照が不正または不完全です。というメッセージが出るのですが、どこを修正すればよいのでしょうか 教えてください。 Sub 再表示1() Dim SheetName As String Dim i As Integer Dim LastRow As Integer Dim rng As Range LastRow = 3000 '最終行の番号 Sheets("ＡＣＴ").Select For i = 6 To LastRow If (.Range("D" & i) = "A310" Or .Range("D" & i) = "A505") And .Range("V" & i) < 0 Then .Cells(i, "W").Resize(1, 3).ClearContents End If Next Stop End With End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルのマクロで複数セル指定は？
以前（7月22日 質問No.936181）の質問でご回答を頂いたマクロなんですが、 Private Sub Worksheet_Change(ByVal Target As Range) Dim MyData As String Dim i As Integer Dim ImaNanji As String Dim SakkiNanji As String Dim ImaNanpun As String Dim SakkiNanpun As String SakkiNanpun = Cells(2, 3).Value ImaNanji = Cells(1, 3).Value ImaNanpun = Mid(ImaNanji, Len(ImaNanji) - 4, 2) If ImaNanpun <> SakkiNanpun Then Application.EnableEvents = False For i = 10 To 2 Step -1 MyData = Cells(i - 1, 2).Value Cells(i, 2).Value = MyData Next i MyData = Cells(1, 1).Value Cells(1, 2).Value = MyData Cells(2, 3).Value = ImaNanpun Application.EnableEvents = True End If End Sub A1のデータをB1からB10に一分おきにつぎつぎに書き込むというものなんですが、ひとつのセルではなく複数のセル（例えばA1からA30の30個のセル）をいっぺんに書き込むようにしたいのですが可能でしょうか？ よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- 検索 マクロ
本を見ながら作ったのですが 検索してくれるのですが A列を検索してくれるのですが検索したいのは B列の4番目から下にあるだけ検索したいのですが どういじればいいのでしょうか？ Option Explicit Private lastRow As Long Private Index As Integer Private Sub UserForm_Activate() Dim i As Long lastRow = Worksheets("顧客情報").Cells(Rows.Count, 1).End(xlUp).Row + 1 If lastRow <= 3 Then MsgBox "データがありません。" Exit Sub End If For i = 3 To lastRow 名前リストボックス.AddItem Cells(i, 1) Next End Sub Private Sub 検索ボタン_Click() Dim searchName As String searchName = 検索名前テキストボックス.Text If searchName = "" Then MsgBox "検索する名前を入力してください。" Else Dim i As Long Dim no As Long For i = 0 To 名前リストボックス.ListCount - 1 If 名前リストボックス.List(i) = searchName Then no = i 名前リストボックス.ListIndex = no Exit For ElseIf i >= 名前リストボックス.ListCount - 1 Then MsgBox "該当なし。" Exit For End If Next Index = no + 3 Rows(Index).Select End If End Sub
- ベストアンサー
- Excel（エクセル）
- マクロで複数の行をまとめて切り取りする方法
Ｉの列のセルに「テスト」があったら、その行を切り取ってシート2に貼り付ける といった流れのコードが下記です。 Sub 切り取り() Dim i, LastRow As Long LastRow = Cells(Rows.Count, 9).End(xlUp).Row For i = 1 To LastRow If Cells(i, 9) = “テスト” Then Rows(i).Cut Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End If Next i End Sub ●Ｉの列のセルに「テスト」と「課題」があったら、その行を切り取ってシート2に貼り付ける といったものをしたいのです。 1. If Cells(i, 9) = “テスト” Then ↓ If Cells(i, 9) = “テスト,課題” Then 結果エラー 2. If Cells(i, 9) = “テスト” Then ↓ If Cells(i, 9) = “テスト&課題” Then 結果エラー 正常なコードを教えてくださいますか？ 宜しくお願いします。
- ベストアンサー
- Visual Basic
- マクロでファイルを読み込み、重複行を削除したい。
35万件以上あるエクセルデータに対して、マクロを使って以下のような処理で重複業を削除したいと思っています。 Sub DeleteOldRow() Dim lastRow As Integer Dim i As Integer Dim j As Integer Dim strVal As String 'B列の最終行を求めます。 lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row '1行目から最終行の前まで繰り返します。 For i = 1 To lastRow - 1 'チェックする値を、strValに代入します。 strVal = ActiveSheet.Cells(i, 2).Value '今見てる行から、下をチェックします。 For j = i + 1 To lastRow 'もし、値が同じであれば、 If strVal = ActiveSheet.Cells(j, 2).Value Then '元の行を削除します ActiveSheet.Rows(i).Delete '最終行が１行減ったのでlastRowの値を減らします。 lastRow = lastRow - 1 'チェックしている行を１行前に戻します。 j = j - 1 End If Next j Next i End Sub 上記処理を３５万件あるファイル上でマクロの実行すると、オーバーフローしてしまいました。マクロ側で対象ファイルを読み込むなどして、処理を軽くするやり方はありますでしょうか。上記処理にどのような処理を加えればスムーズに処理されるでしょうか。
- ベストアンサー
- Visual Basic
- エクセル 検索コピーマクロ
マクロで検索、抽出して別ファイルに保存したいのですが、 以下のようなマクロを教えてもらったのですが コピー先のセル位置を任意の位置に直したいのですが、 どうしてもわかりません どの部分をどう直せばよいのでしょうか？ Option Explicit Sub copyTodayData() Dim dateToday As String Dim tempDate As String Dim lastrow1 As Long Dim lastrow2 As Long Dim i As Long Dim fileA As String Dim anotherBook As String Dim anotherFilePath As String fileA = ThisWorkbook.Name anotherBook = "別のファイル.xls" anotherFilePath = "C:\Documents and Settings\日本太郎\デスクトップ\どこかのフォルダ" '問い合せダイアログの表示をOFFにします Application.DisplayAlerts = False 'ファイルを開く ChDir anotherFilePath Workbooks.Open Filename:=anotherFilePath & "\" & anotherBook '問い合せダイアログの表示をONに戻します Application.DisplayAlerts = True 'ウインドウの切替 Windows(fileA).Activate '今日の日付を取得 dateToday = Date 'データ最終行を取得 lastrow1 = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To lastrow1 If Cells(i, 1) = dateToday Then 'Range(Cells(i, 1), Cells(i, 4)).Copy 'コピー Windows(anotherBook).Activate 'ウインドウの切替 lastrow2 = Cells(Rows.Count, 1).End(xlUp).Row '別ブックの最終行 Cells(lastrow2 + 1, 1).Select ActiveSheet.Paste Windows(fileA).Activate 'ウインドウの切替 End If Next i MsgBox "実行しました" End Sub たぶん、lastrow2 = Cells(Rows.Count, 1).End(xlUp).Row '別ブックの最終行 Cells(lastrow2 + 1, 1).Select ここらへんというのは、わかりますが、 どこをどう変えたらいいかわかりません
- 締切済み
- その他MS Office製品
- マクロ 修正 （初心者です）
Option Explicit Private lastRow As Long Private Index As Integer Private Sub CommandButton1_Click() Unload Me End Sub Private Sub あいまいボタン_Click() Dim last As Long If 検索名前テキストボックス.Text = "" Then MsgBox "あいまい抽出する名前を入力してください。" Exit Sub End If last = Range("A500").End(xlUp).Row Range("A2:D" & last).AutoFilter Field:=2, Criteria1:="=*" & 検索名前テキストボックス.Text & "*" End Sub Private Sub UserForm_Activate() Dim i As Long lastRow = Worksheets("顧客情報").Cells(Rows.Count, 1).End(xlUp).Row + 1 If lastRow <= 3 Then Exit Sub End If For i = 4 To lastRow 名前リストボックス.AddItem Cells(i, 2) Next End Sub Private Sub 検索ボタン_Click() Dim searchName As String searchName = 検索名前テキストボックス.Text If searchName = "" Then MsgBox "検索する名前を入力してください。" Else Dim i As Long Dim no As Long For i = 0 To 名前リストボックス.ListCount - 1 If 名前リストボックス.List(i) = searchName Then no = i 名前リストボックス.ListIndex = no Exit For ElseIf i >= 名前リストボックス.ListCount - 1 Then MsgBox "該当なし。" Exit For End If Next Index = no + 3 Rows(Index).Select End If End Sub B列に名前を入力しています B3から検索してくれるマクロを作成しました（インターネット見ながら） 別の検索も作りたくてどこをいじればいいのかわからず書き込みました G3列（住所を検索）から下側を検索したいのですがどこをいじればいいでしょうか？
- ベストアンサー
- Visual Basic
