CALENDAR
S M T W T F S
      1
2345678
9101112131415
16171819202122
23242526272829
3031     
<< October 2011 >>
SPONSORED LINKS
ARCHIVES
CATEGORIES
RECOMMEND
ザッピング
ヤフーログール
あわせてよみたい
とらっくわーど
MOBILE
qrcode
スポンサーサイト

一定期間更新がないため広告を表示しています

| - | | - | - | pookmark |
VBA でフォルダを作る
 いろんなことができるんだなー。

こちらで紹介されているソース 文句なくこのまま動きます。



Sub Test()
Dim objFSO As Object
Dim myFolder As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
myFolder = ThisWorkbook.Path & "¥hoge"
If objFSO.folderexists(folderspec:=myFolder) = False Then
   objFSO.createfolder myFolder
   MsgBox "フォルダを作成しました。"
End If
Set objFSO = Nothing
End Sub

| VBA | 10:30 | - | - | pookmark |
値があるかどうかを調べる
ウェブサイトに表示する用語を決めておいて、
追加する値がそれに適合しているかどうかを調べます。
 
VBAで書こうとしたんだけど結構長くなってしまう。
ということで、エクセルの関数を使うことにしました。


 =IF(COUNTIF(範囲,検索条件),"真の場合の値","偽の場合の値")


| VBA | 15:43 | - | - | pookmark |
複数のシートをCSV保存する
エクセルの複数のシートを、1つずつ別のCSVファイルに保存する方法について。
非常にスマートなコードを書いている人発見。


Sub Test()
Dim ws As Worksheet
 On Error Resume Next
 For Each ws In ActiveWorkbook.Worksheets
   ws.SaveAs ThisWorkbook.Path & "¥" & ws.Name & ".csv", xlCSV
 Next ws
End Sub



文句なく動きました。
神様的〜。
| VBA | 15:26 | - | - | pookmark |
作業工程
 Sub 複数取得()

i = 1

Do While Sheets("2words").Cells(i, 1) <> ""


myurl = Sheets("2words").Cells(i, 6)
mycat = Sheets("2words").Cells(i, 3)

Worksheets.Add.Name = mycat
Worksheets(mycat).Activate
Cells(1, 1).Value = "印刷会社名"
Cells(1, 2).Value = Sheets("表紙").Cells(1, 2).Value
Cells(2, 1).Value = "印刷方法"
Cells(2, 2).Value = Sheets("表紙").Cells(2, 2).Value
Cells(3, 1).Value = "商品名"
Cells(3, 2).Value = Sheets("表紙").Cells(3, 2).Value
Cells(4, 1).Value = "仕上がりサイズ"
Cells(4, 2).Value = Sheets("表紙").Cells(4, 2).Value
Cells(5, 1).Value = "用紙種類"
Cells(5, 2).Value = Sheets("2words").Cells(i, 1)
Cells(6, 1).Value = "納期"
Cells(6, 2).Value = Sheets("2words").Cells(i, 2)
Cells(7, 1).Value = "ページ数"
Cells(7, 2).Value = Sheets("表紙").Cells(7, 2).Value
Cells(8, 1).Value = "色パターン"
Cells(8, 2).Value = Sheets("表紙").Cells(8, 2).Value
Cells(9, 1).Value = "リンクURL"
Cells(9, 2).Value = myurl
Cells(10, 1).Value = "備考"
Cells(10, 2).Value = ""

With ActiveSheet.QueryTables.Add(Connection:="URL;" & myurl, _
Destination:=Range("A11"))
.Name = mycat
.WebSelectionType = xlSpecifiedTables
.WebTables = "3"
.Refresh
End With

i = i + 1

Loop


End Sub



Sub twowords()



Dim i As Long

Dim myno As Long



'要素1(用紙)のワードの個数を数えます。

Sheets("source").Select

Range(Cells(2, 1), Cells(2, 1).End(xlDown)).Select

myno1 = Selection.Rows.Count

'要素2(納期)のワードの個数を数えます。

Range(Cells(2, 3), Cells(2, 3).End(xlDown)).Select

myno2 = Selection.Rows.Count



'要素の意味の組み合わせを作成します
i = 1

Do While i <= myno1

Sheets("2words").Select

Range(Cells(myno2 * (i - 1) + 1, 1), Cells(myno2 * i, 1)).Value = Sheets("source").Cells(i + 1, 1).Value

Range(Cells(myno2 * (i - 1) + 1, 2), Cells(myno2 * i, 2)).Value = Range(Sheets("source").Cells(2, 3), Sheets("source").Cells(myno2 + 1, 3)).Value


'要素のIDの組み合わせを作成します
Range(Cells(myno2 * (i - 1) + 1, 4), Cells(myno2 * i, 4)).Value = Sheets("source").Cells(i + 1, 2).Value

Range(Cells(myno2 * (i - 1) + 1, 5), Cells(myno2 * i, 5)).Value = Range(Sheets("source").Cells(2, 4), Sheets("source").Cells(myno2 + 1, 4)).Value



i = i + 1

Loop



'シート名とURLを作成します

j = 1

Do While Sheets("2words").Cells(j, 1) <> ""


Sheets("2words").Select

Cells(j, 3).Value = Cells(j, 1) & "_" & Cells(j, 2)
Cells(j, 6).Value = "http://www.graphic.jp/price/" & Sheets("表紙").Cells(3, 4) & "_" & Cells(j, 4) & "_" & Cells(j, 5)

j = j + 1

Loop




End Sub


Sub 余分な行を削除()

Worksheets.Select Replace:=False
    Rows("11:11").Select
    Selection.Delete Shift:=xlUp

End SubJUGEMテーマ:日記・一般
| VBA | 18:44 | - | - | pookmark |
列が分かれている場合の複合ワード
2ワード複合の場合↓

 Sub twowords()


Dim i As Long

Dim myno As Long



'1列目のワードの個数を数えます。

Sheets("source").Select

Range(Cells(1, 1), Cells(1, 1).End(xlDown)).Select

myno1 = Selection.Rows.Count

'2列目のワードの個数を数えます。

Range(Cells(1, 2), Cells(1, 2).End(xlDown)).Select

myno2 = Selection.Rows.Count




'組み合わせを作成します

i = 1

Do While i <= myno1

Sheets("2words").Select

Range(Cells(myno2 * (i - 1) + 1, 1), Cells(myno2 * i, 1)).Value = Sheets("source").Cells(i, 1).Value

Range(Cells(myno2 * (i - 1) + 1, 2), Cells(myno2 * i, 2)).Value = Range(Sheets("source").Cells(1, 2), Sheets("source").Cells(myno2, 2)).Value



'Range(Cells(myno * (i - 1) + 1, 1), Cells(myno * i, 1)).Value = Sheets("source").Cells(i, 1).Value

'With Sheets("source")

'Range(Cells(myno * (i - 1) + 1, 2), Cells(myno * i, 2)).Value = .Range(.Cells(1, 1), .Cells(myno, 1)).Value

'End With

i = i + 1

Loop



End Sub



3ワード複合の場合↓


Sub threewords()



'3列目のワードの個数を数えます。

Sheets("source").Select

Range(Cells(1, 3), Cells(1, 3).End(xlDown)).Select

myno3 = Selection.Rows.Count


'2words複合のワードの個数を数えます。

Sheets("2words").Select

Range(Cells(1, 1), Cells(1, 1).End(xlDown)).Select

myno1_2 = Selection.Rows.Count



j = 1

Do While j <= myno3

Sheets("3words").Select

Range(Cells(myno1_2 * (j - 1) + 1, 1), Cells(myno1_2 * j, 2)).Value = Range(Sheets("2words").Cells(1, 1), Sheets("2words").Cells(myno1_2, 2)).Value

Range(Cells(myno1_2 * (j - 1) + 1, 3), Cells(myno1_2 * j, 3)).Value = Sheets("source").Cells(j, 3).Value

'Range(Cells(myno * (i - 1) + 1, 1), Cells(myno * i, 1)).Value = Sheets("source").Cells(i, 1).Value

'With Sheets("source")

'Range(Cells(myno * (i - 1) + 1, 2), Cells(myno * i, 2)).Value = .Range(.Cells(1, 1), .Cells(myno, 1)).Value

'End With

j = j + 1

Loop




End Sub

| VBA | 20:17 | - | - | pookmark |
認可保育園の申込書
 JUGEMテーマ:日記・一般

認可保育園の申込書が以下からダウンロード可能。
提出期限は12月16日


しかし、奥まったところにあった。

川崎市トップ>健康福祉情報
から行くのだが、人か保育園で健康福祉情報選ばせるってハードル高い。

| 教育 | 09:50 | - | - | pookmark |
親子留学
 フィジーの親子留学
11月からお休みに入り、新学期2月から。
母親は観光ビザ4カ月+延長2か月
| 教育 | 15:11 | - | - | pookmark |
親族の葬儀
数珠は一重の略式の数珠があれば宗派を問わず使える
数珠は左手で持つ

香典を袱紗に包む:香典袋を中央に置き右・下・上・左の順に袱紗を折る。
祝儀袋を袱紗に包む:左・上・下・右の順に折る。

通夜には、通夜振る舞いと言われるしきたりがあり、折り詰の弁当やサンドイッチ、お寿司などが多い。地域によっては、茶菓子とお茶が用意されるか、お食事やお酒が用意される。 
通夜と葬儀の両方に参列する場合、香典をどちらで出すのかは、地域によって違う 。
スカートの場合はストッキングは黒
光沢がある素材のバッグや靴などは避ける。

近い親族が亡くなった場合:
香典は5万円〜10万円
供花や供物を喪主と相談して準備
問客には「本日は御丁寧に恐れ入ります」と挨拶

| その他 | 00:58 | - | - | pookmark |
先に表の取り込みだけしてしまう例
 とりあえずCSV保存は後回しにして、先にまとめて表の取り込みだけしてしまいます。

--------------------------------------------------------------------------
Sub 複数取得()

i = 1

Do While Sheets("価格表取得").Cells(i, 2) <> ""


myurl = Sheets("価格表取得").Cells(i, 2)
mycat = Sheets("価格表取得").Cells(i, 1)

Worksheets.Add.Name = mycat
Worksheets(mycat).Activate

With ActiveSheet.QueryTables.Add(Connection:="URL;" & myurl, _
Destination:=Range("B5"))
.Name = "取り込みデータ"
.WebSelectionType = xlSpecifiedTables
.WebTables = "3"
.Refresh
End With

i = i + 1

Loop


End Sub
--------------------------------------------------------------------------

| VBA | 13:12 | - | - | pookmark |
CSV保存がうまくいかない例
以下だとCSV保存がうまくいきません。
理由は多分取り込みに時間がかかってしまうので、
取り込み完了前にCSV保存しようとしてしまうためと思われます。
----------------------------------------------
 Sub シートを保存()

Sheets("価格表取得").Activate


myurl = Range("B4")

With ActiveSheet.QueryTables.Add(Connection:="URL;" & myurl, _
Destination:=Range("B5"))
.Name = "取り込みデータ"
.WebSelectionType = xlSpecifiedTables
.WebTables = "3"
.Refresh
End With

       '確認ダイアログを一時的に非表示にします
       Application.DisplayAlerts = False
       
'       myname = Range("A4")
'       ActiveWorkbook.SaveAs Filename:="C:¥Users¥****¥Desktop¥今日のFTP" & myname, FileFormat:=xlCSV
       ActiveWorkbook.SaveAs Filename:="C:¥Users¥****¥Desktop¥今日のFTP¥保存できてるか", FileFormat:=xlCSV
       ActiveWorkbook.Close Savechanges:=False

       '確認ダイアログの非表示を元に戻します
      Application.DisplayAlerts = True

End Sub

----------------------------------------------
JUGEMテーマ:日記・一般

| VBA | 13:10 | - | - | pookmark |
| 1/2PAGES | >>