ブックを開いたときにCSVのデータベースをコピーする

2017–09–29 (Fri) 22:21
「ブックを開いたときにCSVのデータベースをコピーする」マクロを作成しました。

VBAのエディタを開きMicrosoft Excel Objects の「Thisworkbook」に記入する。
・コピーしたいシート名 に シート名
・読み込むCSVをtxtファイルにする にアドレスを入れる
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Dim ws As Worksheet, flg As Integer
flg = 0
For Each ws In ThisWorkbook
If ws.Name = "コピーしたいシート名" Then
flg = 1
Exit For
End If
Next
If flg = 0 Then
ThisWorkbook.Worksheets.Add
ActiveSheet.Name = "コピーしたいシート名"
Dim aWb As Workbook
Set aWb = ActiveWorkbook
Dim aWs As ActiveWorkbook
Set aWs = Worksheets("コピーしたいシート名")
Dim TextPath As String

TextPath = "読み込むCSVをtxtファイルにする"
Workbooks.Opentext Filename:=TextPath, _
DataType:=xlDelimited, _
Tab:=True, _
Semicolon:=False, _
Comma:=True, _
Space:=False, _
Other:=True, _
Otherchar:="/"

ActiveWorkbook.Sheets(1).Cells.Copy aWs.Range("A1")
ActiveWorkbook.Close False

Application.ScreenUpdating = True
End Sub

無題

ブックを開いたときにCSVのデータベースをコピーする.pdf
スポンサーサイト

表示マクロ マニュアル

2017–09–27 (Wed) 22:00
表示マクロ マニュアル.pdf

これから、マニュアルを色々と作成しなければならなくなりました。アドインの共有とかが出てくるので本当に大変です;;;

無題

結局メンテナンスをするのも私だし、メンテナンス出来る人がいなくなったらどうするんだろう……。私、移動の話でてるんだけどなあ← 代表から次の場所へって言われてるのよ!!!

表示マクロ

2017–09–25 (Mon) 22:26
Function HyouG(表示 As Variant)
HyouG = Format(表示, "g")
End Function
Function HyouGGG(表示 As Variant)
HyouGGG = Format(表示, "ggg")
End Function
Function HyouYYYY(表示 As Variant)
HyouYYYY = Format(表示, "yyyy")
End Function
Function HyouE(表示 As Variant)
HyouE = Format(表示, "e")
End Function
Function HyouM(表示 As Variant)
HyouM = Format(表示, "m")
End Function
Function HyouD(表示 As Variant)
HyouD = Format(表示, "d")
End Function

Function HyouGEN(表示 As Variant)
HyouGEN = Format(表示, "ge年")
End Function
Function HyouMG(表示 As Variant)
HyouMG = Format(表示, "m月")
End Function
Function HyouDN(表示 As Variant)
HyouDN = Format(表示, "d日")
End Function
Function HyouGGGEN(表示 As Variant)
HyouGGGEN = Format(表示, "ggge年")
End Function

無題

setH(表示指定)関数を作成しました。

2017–09–23 (Sat) 18:21
ユーザ定義(表示)を入れたセルにこの関数を入れると、関数が固定させます。
マクロはこういう痒いところに手が届くのがいいですね。
「固定してたのに変わりやがった。エクセルの馬鹿」と言うのが嫌なのでb

Function setH(nm As Variant)
Dim hk As Variant
hk = Range(Application.ThisCell.Address).NumberFormatLocal
setH = WorksheetFunction.Text(nm, hk)
End Function

VLOOKUPS 関数。

2017–09–22 (Fri) 18:26
VLOOKUPS 関数。
Vlookups + 細かく指定 が出来る関数を作成いたしました。検索する文字列と列番号は、文字列、列番号、文字列、列番号の順番で入力してください。

通常のVlookupで複数条件検索の出来る関数です。今まではワイルドカードが使えなかったのですが、今回からワイルドカードが使える様になりました。*(アスタリスク)指定が出来ます。

Function VlookupShitei(範囲 As Range, 列番号 As Long, ParamArray 検索する文字列と列番号())
Dim hani As Variant, owari As Long, MaxCol As Long, i As Long, j As Long, check As Long, ken As Variant
Dim RE, strPattern As String, msg As String, reMatch
Set RE = CreateObject("VBScript.RegExp")
hani = 範囲
owari = UBound(hani, 1)
MaxCol = UBound(hani, 2)
ReDim ken(owari, UBound(検索する文字列と列番号) + 1)
If (UBound(検索する文字列と列番号) + 1) Mod 2 = 0 Then
Dim k As Integer
For i = 0 To UBound(検索する文字列と列番号) Step 2
strPattern = Replace(検索する文字列と列番号(i), "*", ".*")
With RE
.Pattern = strPattern
.IgnoreCase = True
.Global = True
For j = 1 To owari
On Error Resume Next
Set reMatch = .Execute(範囲(j, 検索する文字列と列番号(i + 1)))
On Error GoTo 0
If IsEmpty(reMatch) = False Then
If reMatch.Count > 0 Then
ken(j, i) = j
End If
End If

Next
End With

Next
For i = 0 To UBound(ken)
check = 0
For j = 0 To UBound(検索する文字列と列番号) + 1
If ken(i, j) <> "" Then
check = check + 1
End If
If check = (UBound(検索する文字列と列番号) + 1) / 2 Then
VlookupShitei = 範囲(i, 列番号)
Exit Function
End If
Next
Next
If IsEmpty(VlookupShitei) = True Then
VlookupShitei = ""
End If
Else
VlookupShitei = ""
End If


Set reMatch = Nothing
Set RE = Nothing
End Function


次は下から検索するUVlookupの指定バージョンです。

Function UVlookupShitei(範囲 As Range, 列番号 As Long, ParamArray 検索する文字列と列番号())
Dim hani As Variant, owari As Long, MaxCol As Long, i As Long, j As Long, check As Long, ken As Variant
Dim RE, strPattern As String, msg As String, reMatch
Set RE = CreateObject("VBScript.RegExp")
hani = 範囲
owari = UBound(hani, 1)
MaxCol = UBound(hani, 2)
ReDim ken(owari, UBound(検索する文字列と列番号) + 1)
If (UBound(検索する文字列と列番号) + 1) Mod 2 = 0 Then
Dim k As Integer
For i = 0 To UBound(検索する文字列と列番号) Step 2
strPattern = Replace(検索する文字列と列番号(i), "*", ".*")
With RE
.Pattern = strPattern
.IgnoreCase = True
.Global = True
For j = owari To 1 Step -1
On Error Resume Next
Set reMatch = .Execute(範囲(j, 検索する文字列と列番号(i + 1)))
On Error GoTo 0
If IsEmpty(reMatch) = False Then
If reMatch.Count > 0 Then
ken(j, i) = j
End If
End If

Next
End With

Next
For i = UBound(ken) To 0 Step -1
check = 0
For j = 0 To UBound(検索する文字列と列番号) + 1
If ken(i, j) <> "" Then
check = check + 1
End If
If check = (UBound(検索する文字列と列番号) + 1) / 2 Then
UVlookupShitei = 範囲(i, 列番号)
Exit Function
End If
Next
Next
If IsEmpty(UVlookupShitei) = True Then
UVlookupShitei = ""
End If
Else
UVlookupShitei = ""
End If
Set reMatch = Nothing
Set RE = Nothing
End Function

なかなか綺麗なマクロを作ることが出来ないのが悔しくて悲しいです。
エラー処理無し 条件が満たない場合は自動で空白になります。

VLOOKUPS 関数.docx

VLOOKUPS 関数.pdf

VlookupShitei を作ってみました

2017–09–22 (Fri) 14:38
VlookupShitei を作ってみました。
これ、どうなのかなあ;;;
Microsoftさん作らないかなあ←(笑) 最強の「IFS」関数もでたんだからさあ~~~。出してくれてもいいじゃない!!!



Function VlookupShitei(範囲 As Range, 列番号 As Long, ParamArray 検索する文字列と列番号())
Dim hani As Variant, owari As Long, MaxCol As Long, i As Long, j As Long, check As Long, ken As Variant
Dim RE, strPattern As String, msg As String, reMatch
Set RE = CreateObject("VBScript.RegExp")
hani = 範囲
owari = UBound(hani, 1)
MaxCol = UBound(hani, 2)
ReDim ken(owari, UBound(検索する文字列と列番号) + 1)
If (UBound(検索する文字列と列番号) + 1) Mod 2 = 0 Then
Dim k As Integer
For i = 0 To UBound(検索する文字列と列番号) Step 2
strPattern = Replace(検索する文字列と列番号(i), "*", ".*")
With RE
.Pattern = strPattern
.IgnoreCase = True
.Global = True
For j = 1 To owari
On Error Resume Next
Set reMatch = .Execute(範囲(j, 検索する文字列と列番号(i + 1)))
On Error GoTo 0
If IsEmpty(reMatch) = False Then
If reMatch.Count > 0 Then
ken(j, i) = j
End If
End If

Next
End With

Next
For i = 0 To UBound(ken)
check = 0
For j = 0 To UBound(検索する文字列と列番号) + 1
If ken(i, j) <> "" Then
check = check + 1
End If
If check = (UBound(検索する文字列と列番号) + 1) / 2 Then
VlookupShitei = 範囲(i, 列番号)
Exit Function
End If
Next
Next
If IsEmpty(VlookupShitei) = True Then
VlookupShitei = ""
End If
Else
VlookupShitei = ""
End If


Set reMatch = Nothing
Set RE = Nothing
End Function


n番煎じだとは思いますけどね……。こう言うのを作っているときが一番好きです。

クライスラーの「愛の悲しみ」って良い曲だね。美しい;;;



ピアノ版はあんまり好きでは無いですが、ピアノの独奏も有るのですよ。有名な曲だから間違えたらばれそう(特に最初)

UVlookup・Umatch を作りました。

2017–09–19 (Tue) 21:29
Uvlookup は、VLOOKUPを下からする物です(Under Vlookupです)

Function Uvlookup(検索する文字列 As String, 範囲 As Range, 列番号 As Long)
Dim hani As Variant, owari As Long, MaxCol As Long, i As Long, j As Long
hani = 範囲
owari = UBound(hani, 1)
MaxCol = UBound(hani, 2)
For i = owari To 1 Step -1
If InStr(hani(i, 1), 検索する文字列) <> 0 Then
Uvlookup = hani(i, 列番号)
Exit For
End If
Next
End Function

Umatch は、matchを下からする物です(Under Matchです)
Function Umatch(検索する文字列 As String, 範囲 As Range)
Dim hani As Variant, owari As Long, MaxCol As Long, i As Long, j As Long
hani = 範囲
owari = UBound(hani, 1)
For i = owari To 1 Step -1
If InStr(hani(i, 1), 検索する文字列) <> 0 Then
Umatch = i + 範囲.Row - 1
Exit For
End If
Next
End Function

UVLOOKUPは使いやすいかもしれませんね。Matchも使いやすいかも……。どうかなあ??? 皆様是非お使い下さい。
あともう一つ作りたいので、今からそれを作ってきます(*^_^*)(*^_^*)

アクティブシートをコピーして検索文字列の色を変更する

2017–09–19 (Tue) 07:37
おはようございます。
今日のマクロはアクティブシートをコピーし、検索文字列を指定。その後色を変更すると言うマクロです。私はたまに使うのですが、一般的にどのぐらい使うのかな……?と言う感じです;;;
Ctrl+Fは使い勝手の悪いときも有りますし、そう言うときはこっちの方が便利なのです……。

Sub アクティブシートをコピーして検索文字列の赤色にする()
Dim buf As String, MaxRow As Long, MaxCol As Long
buf = InputBox("名前を入力してください")
Application.ScreenUpdating = False
ActiveWorkbook.ActiveSheet.Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
Dim i As Long, j As Long
Dim ken As Variant
ken = Range(Cells(1, 1), Cells(MaxRow, MaxCol))
For i = 1 To MaxRow
For j = 1 To MaxCol
If InStr(ken(i, j), buf) <> 0 Then
Cells(i, j).Characters(Start:=InStr(ken(i, j), buf), Length:=Len(buf)).Font.ColorIndex = 3
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Sub アクティブシートをコピーして検索文字列の青色にする()
Dim buf As String, MaxRow As Long, MaxCol As Long
buf = InputBox("名前を入力してください")
Application.ScreenUpdating = False
ActiveWorkbook.ActiveSheet.Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
Dim i As Long, j As Long
Dim ken As Variant
ken = Range(Cells(1, 1), Cells(MaxRow, MaxCol))
For i = 1 To MaxRow
For j = 1 To MaxCol
If InStr(ken(i, j), buf) <> 0 Then
Cells(i, j).Characters(Start:=InStr(ken(i, j), buf), Length:=Len(buf)).Font.ColorIndex = 5
End If
Next
Next
Application.ScreenUpdating = True
End Sub

Sub アクティブシートをコピーして検索文字列の緑色にする()
Dim buf As String, MaxRow As Long, MaxCol As Long
buf = InputBox("名前を入力してください")
Application.ScreenUpdating = False
ActiveWorkbook.ActiveSheet.Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
Dim i As Long, j As Long
Dim ken As Variant
ken = Range(Cells(1, 1), Cells(MaxRow, MaxCol))
For i = 1 To MaxRow
For j = 1 To MaxCol
If InStr(ken(i, j), buf) <> 0 Then
Cells(i, j).Characters(Start:=InStr(ken(i, j), buf), Length:=Len(buf)).Font.ColorIndex = 10
End If
Next
Next
Application.ScreenUpdating = True
End Sub

Sub アクティブシートをコピーして検索文字列の黄色にする()
Dim buf As String, MaxRow As Long, MaxCol As Long
buf = InputBox("名前を入力してください")
Application.ScreenUpdating = False
ActiveWorkbook.ActiveSheet.Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
Dim i As Long, j As Long
Dim ken As Variant
ken = Range(Cells(1, 1), Cells(MaxRow, MaxCol))
For i = 1 To MaxRow
For j = 1 To MaxCol
If InStr(ken(i, j), buf) <> 0 Then
Cells(i, j).Characters(Start:=InStr(ken(i, j), buf), Length:=Len(buf)).Font.ColorIndex = 27
End If
Next
Next
Application.ScreenUpdating = True
End Sub

弾きたい~~~

マクロの使い方PDF

2017–09–18 (Mon) 21:43
マクロの使い方を書いたPDFを作りました。
マクロの使い方 送付用.pdf

無題

こう言うようなPDFです。EXCEL2007、EXCEL2010の物を作成しました。EXCEL2013・2016はもうしばらくお待ち下さい。これは、ご自由にお配り頂いて構いません!!!


貯蓄額管理リスト

2017–09–18 (Mon) 18:07
貯蓄額管理リストが欲しいと言うリクエストが有ったので作ってみました。
貯蓄率も出すことが出来ます。

無題

ボーナスがある場合は追加して下さい。

貯金額管理リスト.xlsx

 | HOME |  次へ »

プロフィール

あゆみ

Author:あゆみ
FC2ブログへようこそ!

最新記事

最新コメント

フリーエリア

月別アーカイブ

カテゴリ

ブロとも申請フォーム

検索フォーム

RSSリンクの表示

リンク