のセルA1に特定の文字が入力されているファイルに対してマクロを実行したいのです。
会社のイントラネットから各種データを開くと（ダウンロードではありません。）以下のファイル名になります。
list.csv , list(1).csv , list(2).csv , list(4).csv , … , list(n).csv ←list(3).csvは不要だったので閉じられている例です。
マクロ実行前に、例えば list.csv と list(4) のセルA1に特定の文字が入力されている場合は、どちらかを選択するか、処理を中止する。（希望は前者ですが。。。）
対象のCSVファイルが無ければ（CSVファイルが開かれていない、または、A1が不一致）メッセージを出力する。
Sub Sample()
Dim myChkBook As Workbook
Dim i As Integer
On Error GoTo Err0
Set myChkBook = Workbooks("List.csv") 'この時にセルA1の文字を比較したいです。
Call 処理
Exit Sub
Err0:
For i = 1 To 5 '←５は少なくとも list(n).csv のｎまで処理したい。
On Error Resume Next
Set myChkBook = Workbooks("List(" & i & ").csv") '←現状では、開かれていないファイルが
On Error GoTo 0 'あるとエラーになってしまいます。
Call 処理
Exit Sub
Next i
Exit Sub
Err1:
MsgBox "対象のＣＳＶファイルが見つかりませんでした。"
End Sub
出だしで躓いてしまい、悩んでおります。
良い方法をご教示いただければと思い、質問致します。
宜しくお願い致します。
のセルA1に特定の文字が入力されているファイルに対してマクロを実行したいのです。
会社のイントラネットから各種データを開くと（ダウンロードではありません。）以下のファイル名になります。
list.csv , list(1).csv , list(2).csv , list(4).csv , … , list(n).csv ←list(3).csvは不要だったので閉じられている例です。
マクロ実行前に、例えば list.csv と list(4) のセルA1に特定の文字が入力されている場合は、どちらかを選択するか、処理を中止する。（希望は前者ですが。。。）
対象のCSVファイルが無ければ（CSVファイルが開かれていない、または、A1が不一致）メッセージを出力する。
Sub Sample()
Dim myChkBook As Workbook
Dim i As Integer
On Error GoTo Err0
Set myChkBook = Workbooks("List.csv") 'この時にセルA1の文字を比較したいです。
Call 処理
Exit Sub
Err0:
For i = 1 To 5 '←５は少なくとも list(n).csv のｎまで処理したい。
On Error Resume Next
Set myChkBook = Workbooks("List(" & i & ").csv") '←現状では、開かれていないファイルが
On Error GoTo 0 'あるとエラーになってしまいます。
Call 処理
Exit Sub
Next i
Exit Sub
Err1:
MsgBox "対象のＣＳＶファイルが見つかりませんでした。"
End Sub
出だしで躓いてしまい、悩んでおります。
良い方法をご教示いただければと思い、質問致します。
宜しくお願い致します。
Excel2010使用。
VBA初心者である為、
何度か質問させていただきながら
回答いただいた内容に修正を加えつつ、
思いのものがひと通りできたと
解決していたつもりだったのですが、
動作確認をしたところ、一部不具合が生じました。
自己解決を試みているのですが、解決できず困っております。
どなたかお助けいただけないでしょうか？
Private Sub 登録_Click()
'登録ボタン押下で勤務表にデータを登録
Dim row As Integer
Application.ScreenUpdating = False '画面更新の抑制
row = WorksheetFunction.CountA(Sheets("勤務表").Columns(1)) + 1
myCol = 1
Sheets("勤務表").Cells(row, 1).Value = Range("T2").Value
Sheets("勤務表").Cells(row, 34).Value = Range("T1").Value
For i = 8 To 22 Step 7
For j = 6 To 26 Step 2
If IsEmpty(Cells(j, i)) Then
Exit For
Else
myCol = myCol + 1
With Sheets("勤務表").Cells(row, myCol)
.Value = Cells(j, i).Value
If LenB(StrConv(Cells(j, i).Value, vbFromUnicode)) > 8 Then '(1) ここを修正
.WrapText = True
.Font.Size = 6
End If
End With
End If
Next j
Next i
Sheets("勤務表").Cells(5, 22).Value = Range("P3").Value '月末日を移す
Range("T1").ClearContents '連続入力の為、消去
Range("E6:G25").ClearContents
Range("L6:N25").ClearContents
Range("S6:U27").ClearContents
Application.ScreenUpdating = True '抑制の解除
Range("T1").Select
End Sub
上記コードを作成し、
入力用のシートから勤務表シートに
1人ずつ登録していくようにしております。
入力用のシートのH6:H24、O6:O24、V6:V26
（シートの都合により2行を1行に結合しています）
このマクロを実行したところ、
V24までは転記ができているのですが、
V26だけが転記できない状況となっています。
CellsでいくとCells（22,26）まで範囲に入っていると
思うのですが・・・。
どこがおかしいのでしょうか？
Excelのワークシート上に画像(pic1)と四角の図形(waku)があります。
pic1にwakuを重ね、トリミングする場所を視覚的に確認したあと、VBAを実行し、wakuと同じ位置・サイズでpic1をトリミングするということを考えています。
とりあえず、実験的に左側をトリミングするマクロを作ってみましたがうまくいきません。
やってみた手順としては・・・
1.wakuの左端位置を取得
2.pic1の左端位置を取得
3.その差分を取得
4.差分と同サイズ、pic1の左側をトリミングする
・・・です。
Sub 左端をトリミング()
'枠の位置を取得
Dim wLeft As Single
wLeft = ActiveSheet.Shapes("waku").Left
'写真の位置を取得
Dim pLeft As Single
pLeft = ActiveSheet.Shapes("pct1").Left
'左側の差分を取得
Dim lTrim As Single
lTrim = wLeft - pLeft
ActiveSheet.Shapes("pct1").Select
Selection.ShapeRange.PictureFormat.CropLeft = lTrim
End Sub
結果としては想定しているものの２倍分くらい、トリミングされてしまいます。
最後の一文が、よくわからないまま、ネットから拾ってきた感じで使用しており、そこに問題があるのかと思うのですが・・・
どのようにするのが正しいのか、教えていただければ幸いです。
最終的には同様に上端を、右端・下端についてはそれぞれの図形のサイズの差からトリミングすべきポイントを抽出して希望のサイズにトリミングするつもりでいます。
ちなみに趣旨は・・・
・PCの知識の少ない人でも出来るようにしたい。
・wakuをリサイズさせないことで、縦横比・画像サイズを固定したい。
・・・というものです。
「VBAなんか使わなくても、こうすれば簡単じゃん！」みたいな方法があればあわせて教えていただ得れば幸いです。
Excelのワークシート上に画像(pic1)と四角の図形(waku)があります。
pic1にwakuを重ね、トリミングする場所を視覚的に確認したあと、VBAを実行し、wakuと同じ位置・サイズでpic1をトリミングするということを考えています。
とりあえず、実験的に左側をトリミングするマクロを作ってみましたがうまくいきません。
やってみた手順としては・・・
1.wakuの左端位置を取得
2.pic1の左端位置を取得
3.その差分を取得
4.差分と同サイズ、pic1の左側をトリミングする
・・・です。
Sub 左端をトリミング()
'枠の位置を取得
Dim wLeft As Single
wLeft = ActiveSheet.Shapes("waku").Left
'写真の位置を取得
Dim pLeft As Single
pLeft = ActiveSheet.Shapes("pct1").Left
'左側の差分を取得
Dim lTrim As Single
lTrim = wLeft - pLeft
ActiveSheet.Shapes("pct1").Select
Selection.ShapeRange.PictureFormat.CropLeft = lTrim
End Sub
結果としては想定しているものの２倍分くらい、トリミングされてしまいます。
最後の一文が、よくわからないまま、ネットから拾ってきた感じで使用しており、そこに問題があるのかと思うのですが・・・
どのようにするのが正しいのか、教えていただければ幸いです。
最終的には同様に上端を、右端・下端についてはそれぞれの図形のサイズの差からトリミングすべきポイントを抽出して希望のサイズにトリミングするつもりでいます。
ちなみに趣旨は・・・
・PCの知識の少ない人でも出来るようにしたい。
・wakuをリサイズさせないことで、縦横比・画像サイズを固定したい。
・・・というものです。
「VBAなんか使わなくても、こうすれば簡単じゃん！」みたいな方法があればあわせて教えていただ得れば幸いです。
Sub TeraPad_SF()
'Keyboard Shortcut: Ctrl+Shift+Q
Dim RetVal As Integer
Dim sA As String
Dim sP As String
Dim sV As String
Dim sTxt As String
sV = ActiveCell.Value
sTxt = Left(sV, 1) & ".txt"
'開くファイル名
sA = "D:\WebCamRegistor\txtFolder\" & sTxt
'実行するプログラムのパス
sP = "C:\Program Files\TeraPad\TeraPad.exe "
RetVal = Shell(sP & sA, 1)
If RetVal = 0 Then MsgBox "起動に失敗しました"
AppActivate RetVal
SendKeys "%SF" & sV, True
End Sub
'現在セルの値でAdobeReaderでxx.pdfを検索する
Sub AdobeReader_SF()
'Keyboard Shortcut: Ctrl+Shift+Q
Dim RetVal
Dim sA As String
Dim sP As String
Dim sV As String
Dim sTxt As String
sV = ActiveCell.Value
sTxt = Left(sV, 1) & ".pdf"
'開くファイル名
sA = "D:\WebCamRegistor\pdfFolder\" & sTxt
'実行するプログラムのパス
sP = "C:\Program Files\Adobe\Reader 10.0\Reader\AcroRd32.exe "
RetVal = Shell(sP & sA, 1)
If RetVal = 0 Then MsgBox "起動に失敗しました"
Application.Wait Now + TimeSerial(0, 0, 2)
AppActivate RetVal
SendKeys "^F", True
End Sub
Excel VBA で上は正常に動作しますが、下はAppActivate RetValでエラーとなります。修正の方法をお教えください。
あるサイトの記事をエクセルに落とそうと思い、下記の様なプログラムを組んでみましたが、様々なエラーが出て、かつそのエラーがなぜ起きているのか分からない状態になってしまいました。どのように修正すればよいのか、ご存じの方がいらしたら、ぜひご教授下さい。
もしくは、もっと別のやり方で記事をエクセルに落とせる方法をご存じの方がいらしたら、ぜひご教授下さい。
大雑把な質問になってしまい、「もっと自分で考えてから質問しろ」とお叱りの言葉を頂くかと思います。私自身、なるべく色々と調べてやってきましたが一か月格闘しても遅々として進まずデッドラインが近づいてきておりまして・・・また周りにＶＢＡを知っている人が皆無という状況に耐え切れなくなり、このような質問をしてしまいました。平にご容赦下さい。
また何か補足情報が必要でしたらご遠慮なくコメントいただければと思います。よろしくお願いいたします。
Sub Macro4()
Dim URL As String 'ファイルパス
Dim IE As Object 'オブジェクト
Dim Myhtml As Variant 'HTMLタグデータ
Dim PART As String '収録されているPART
Dim TITLE As String '何話目か
Set IE = CreateObject("InternetExplorer.Application")
PART = 1
Do While PART < 2
TITLE = 0
Do While TITLE < 10
With IE
.Navigate "http://syarecowa.moo.jp/" + PART + "/" + TITLE + ".htm"
.Visible = Falese
Do While .Busy = True
DoEvents
Loop
Myhtml = IE.Document.Body.innerText
Myhtml = Replace(Myhtml, "<BR>", "")
Cells(TITLE, PART) = Myhtml
.Quit
End With
Set IE = Nothing
Loop
Loop
最下層にあるファイルのファイル名を取得したく下記の様なプログラミングを組んでみたところ、
「ファイル名または番号が不正です」というエラーが表示されてしまいます。比較演算子などをいじって
試行錯誤してみましたが、どうしてもできません。どのように修正すればよいのでしょうか。ご回答よろしくお願いいたします。
http://syarecowa.moo.jpというサイトのmenu001.htmの下にある"1/3ケタの数字.htm"のファイル名を全て取得したいと考えています。
現在組めているコードは下記の通りです
Dim cnt As Long
－－－－－－－－－－－－－－－－
Sub Macro5(Path As String)
Dim buf As String, f As Object
buf = Dir(Path & "/#/###.htm") ★★ここでエラーが生じていしまいます★★
Do While buf <> ""
cnt = cnt + 1
Cells(cnt, 1) = buf
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call Macro5(f.Path)
Next f
End With
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub Macro6()
Dim URL As String 'ファイルパス
Dim IE As Object 'オブジェクト
Dim Myhtml As Variant 'HTMLタグデータ
'インターネットに接続
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://syarecowa.moo.jp/menu001.htm"
.Visible = Flase
Do While .Busy = True
DoEvents
Loop
'Macro5呼び出し
cnt = 0
Call Macro5("http://syarecowa.moo.jp/menu001.htm")
End With
End Sub
