CALENDAR
S M T W T F S
     12
3456789
10111213141516
17181920212223
24252627282930
31      
<< March 2024 >>
SPONSORED LINKS
ARCHIVES
CATEGORIES
RECOMMEND
ザッピング
ヤフーログール
あわせてよみたい
とらっくわーど
MOBILE
qrcode
スポンサーサイト

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

| - | | - | - | pookmark |
上下のセルが同じ値だったら結合させるVBA
このままだとA列を結合させる。

デもとはこちらより

============================
Sub セル結合()
Dim r As Integer '行数
Dim i As Integer 'カウンタ
r = Sheets(1).Range("a1").CurrentRegion.Rows.Count - 1

Application.DisplayAlerts = False

For i = 2 To r
   Cells(i, 1).Activate '項目の一つ下のセルをアクティブに
        If ActiveCell.Value = ActiveCell.Offset(1).Value Then
                  Range(ActiveCell, ActiveCell.Offset(1)).Merge
         End If
Next
Application.DisplayAlerts = True
End Sub
============================

結合作業に時間がかかりそうなときは使う。
しかしこの機能はデフォルトで用意しておいてほしい。
逆に結合を解除させたいときは

など。


JUGEMテーマ:日記・一般
| VBA | 10:17 | - | - | pookmark |
空白なら上と同じ値を埋めるVBA
エクセルでセルの結合を解除した時などに便利!
空白なら上と同じ値を埋めるVBA。
1列目の2行目以降に空白セルがあった場合、直上の値と同じ値をセットする。
2列目が空白になるまで続ける。
 


Sub 同じ値を埋める()

 i = 2
 
 Do While Cells(i, 2) <> ""
 If Cells(i, 1).Value = "" Then
 Cells(i, 1).Value = Cells(i - 1, 1).Value
 End If
 i = i + 1
 
 Loop
 

End Sub


| VBA | 23:35 | - | - | pookmark |
VBA 複数シート範囲を指定して置換
なぜかずっと解決されなかった問題が、結局ヘルプで解決したよ、、、

複数ページの11行目だけ変換する場合。

--------------------------------------------------------------
Sub replaceの範囲指定()


For i = 1 To Worksheets.Count

Worksheets(i).Rows(2).Replace _
    What:="の", Replacement:="のだめ", _
    SearchOrder:=xlByColumns, MatchCase:=True

Worksheets(i).Rows(2).Replace _
    What:="めだか", Replacement:="魚"

Next i

End Sub
--------------------------------------------------------------
| VBA | 14:30 | - | - | pookmark |
replace の正規表現
 正規表現、すっかり忘れていました。

学び直し。
サルでもわかる正規表現入門。
http://www.mnet.ne.jp/~nakama/

. ^ $ [ ] * + ? | ( )

| VBA | 12:19 | - | - | 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 |
先に表の取り込みだけしてしまう例
 とりあえず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 |
| 1/5PAGES | >>