プロフィール

るしあ

Author:るしあ
寝ても醒めても編み物のことばかりを考えている、編み物中毒です。

最新記事
最新コメント
月別アーカイブ
カテゴリ
FC2カウンター
Flag Counter
Hello!你好!안녕하십니까 ! Bonjour!Guten Tag!Ciao! Hola!Oi!
free counters

スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

Irisちゃんちょっぴり成長 そして ウルトラスーパーマクロ完成!

みなさんこんばんわー。るしあです。


Irisちゃん、ちょっとだけ成長しました。

20110602iris.jpg

うーん、一段200目って結構手ごわいっす・・・・・。
これでも、オリジナルよりはちょっぴり少ないんですよ、目数。


20110602ichigo.jpg

糸細すぎるんじゃね?


・・・・まぁ確かに細いんですが、このパターンは絶対に細い糸でさらっと編むのがいい!



シルクハセガワさんのギンガリネンです。
あんまり手触りがよいので、また別の色買っちゃおうかなって思ったのですが、実はピーチを持っていて、JBSを編んだライムも余ってるし、その他にもスズも3色持ってるし・・・・
現実を直視してみました。


さて、今日は編み編みの話題はこんなところです。
(短!)


こっからはうるとらスーパーマクロの話。


ちょこちょことExcelマクロの話はさせて頂いていましたが、今日、困ったことに直面してしました。

・・・・・マクロで自動化して効率を上げまくったために、仕事がない・・・・。
(そして余った時間でまたマクロ組んで、また仕事をなくす・・・・。)


そんな余った時間で作ってしまったスーパーマクロはバナーの下でご紹介!

↓応援おねがいします。
ブログランキング・にほんブログ村へ
にほんブログ村
ありがとうございます!



月に3~4種類のレポートを30社あまりの取引先に送るという仕事があるのですが、そのExcelのレポートをひとつひとつ圧縮するのがメンドイ!
いちいちひとつひとつ圧縮ソフトのアイコンの上にドラッグ&ドロップしなければならない!


そこで、もし時間があったら、VBAで圧縮ソフトを制御して自動化してやろうとか思っていたのですが、今日完成してしまいました・・・・ふっふっふ。

指定したフォルダー内のファイルを一括してパスワード付zipに圧縮できるマクロを完成しました!!!!
いやー、るしあ、お前はほんとにすごいよ!(自画自賛過剰)


さっそく噂のウルトラスーパーマクロのご紹介。

まずは指定したフォルダ内のファイル一覧を作成するマクロ。

Sub Display_Directory()
Const cnsTITLE = "フォルダ内のファイル名一覧取得"
Const cnsDIR = "\*.*"
Dim xlAPP As Application
Dim strPATHNAME As String
Dim strFILENAME As String
Dim GYO As Long

Set xlAPP = Application

With Application.FileDialog(msoFileDialogFolderPicker)
 '初期フォルダ設定
.InitialFileName = "C:\DATA\"
'ダイアログのタイトル
.Title = "フォルダを選択してください"

If .Show = True Then
strPATHNAME = .SelectedItems(1)
End If
End With

Sheets(1).Range("A:A").ClearContents
Sheets(1).Range("A1").Value = strPATHNAME & "\"

' 先頭のファイル名の取得
strFILENAME = Dir(strPATHNAME & cnsDIR, vbNormal)
' ファイルが見つからなくなるまで繰り返す
GYO = 1
Do While strFILENAME <> ""
' 行を加算
GYO = GYO + 1 ' 先頭は1行目
Sheets(1).Cells(GYO, 1).Value = strFILENAME
' 次のファイル名を取得
strFILENAME = Dir()
Loop

End Sub

これで1枚目のシートのA1セルにフォルダのパス、A2以降にファイル名が記載されます。

次に、lhaplusを使用して、取得したファイルを全て圧縮します。
圧縮先、パスワードはダイアログボックスで指定します。

Public Sub 圧縮マクロ()
Dim sFromPath As String
Dim sToPath As String
Dim cntR As Long
Dim myPass As String

Const sExePath = "C:\Program Files\Lhaplus\Lhaplus.exe"

With Application.FileDialog(msoFileDialogFolderPicker)
'初期フォルダ設定
.InitialFileName = "C:\DATA\"
'ダイアログのタイトル
.Title = "圧縮先フォルダを選択してください"

If .Show = True Then
sToPath = .SelectedItems(1)
Else
Exit Sub
End If
End With

myPass = InputBox("パスワードを入力して下さい")

cntR = Sheets(1).Range("A1").End(xlDown).Row

For i = 2 To cntR
sFromPath = Sheets(1).Range("A1").Value & Sheets(1).Range("A" & i).Value

Shell Q2(sExePath) & " /c:zip /p:" & Q2(myPass) & " /o:" & Q2(sToPath) & " " & Q2(sFromPath)

Next i

MsgBox ("圧縮完了しました! (*・∀・)ノ '")

End Sub

Public Function Q2(ByVal Text As String) As String
Q2 = """" & Replace(Text, """", """""") & """"
End Function


関連記事
スポンサーサイト

テーマ: 編み物
ジャンル: 趣味・実用

コメント

非公開コメント

カレンダー
08 | 2017/09 | 10
- - - - - 1 2
3 4 5 6 7 8 9
10 11 12 13 14 15 16
17 18 19 20 21 22 23
24 25 26 27 28 29 30
クリック募金!!
クリックするだけで募金ができます♪
東北関東大震災 緊急支援クリック募金
ギャラリー
Ravelry
らべりーの森で彷徨ってます(笑)
ravelry-88x31_p.png


<
リンク
Shop List
いつでも里親募集中
あなたが救える命があります。
メールフォーム

名前:
メール:
件名:
本文:

検索フォーム
RSSリンクの表示
ブロとも申請フォーム

この人とブロともになる

QRコード
QRコード
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。