CSVいろいろ

2017–08–31 (Thu) 18:20
クリップボードを使用してCSVのデータを取ってくる方法です。
場合によっては配列を使用するよりも早いです。

Sub Clipboard CSV()
Application.ScreenUpdating = False

aw = ActiveSheet.Name
Dim aWb As Workbook
Set aWb = ActiveWorkbook
Dim Clipboard As New DataObject

With CreateObject("Scripting.FileSystemObject")
With .GetFile(CSVファイルを指定).OpenAsTextStream
csv = Replace(.ReadAll, ",", Chr(9))
With Clipboard
.SetText csv
.PutInClipboard 'クリップボードに格納
End With
.Close
End With
End With
ActiveSheet.Range("a1").Select
ActiveSheet.Paste

Application.ScreenUpdating = True
End Sub

1359*7 (9513セル)使用のCSVをコピーしたところ、0.02秒程度こちらの方が早かった。
ただ、データが増えると遅くなることが分かった。

無題-2

MB越えるサイズの場合はこの方法が一番良い事が判明した。
(5000*125) データ625000

Sub Opentext CSV()
Application.ScreenUpdating = False

Dim aWb As Workbook
Set aWb = ActiveWorkbook
Dim aWs As activeworkbook
Set aWs = ActiveSheet
aWs = ActiveSheet.Name
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ファイルにに書き込む

2017–08–30 (Wed) 14:18
エクセルマクロですが、ほぼ備忘録です。
なかなか上手く作れず、二時間ほど格闘しました。

データ更新 CSVに書き込むとき

Dim myName As Variant, buf As String
Dim msg() As String, t As Long
Open "CSVファイル指定" For Binary As #1
buf = Space(FileLen("CSVファイル指定"))
Get #1, , buf
Close #1
myName = Split(buf, vbCrLf)
msg2 = Split(myName(1), ",")
ReDim msg(UBound(myName), ubound(msg2))

For i = 0 To UBound(myName)

For t = 0 To UBound(msg2)
msg(i, t) = msg2(t)
Next
Next i

dim naikazu as long
naikazu = 0
データを取ってくる処理を入れます。
CSVにデータが有る場合は、配列をそのまま変更します。

CSVにデータが無い場合の処理。
dim nai as variant
redim nai(ubound(msg2))

nai という配列を作成し、そこに代入します。

nai(0)=・・・


Open "CSVファイル指定" For Append As #1
Print #1, Join(nai, ",")
Close #1
naikazu = naikazu + 1

CSVファイルを開き、追記します。

変更した配列を新しい配列に追記します。

Dim msgmsg As Variant
kosu = naikazu + UBound(msg)
ReDim msgmsg(kosu, 17)
For i = 0 To UBound(msg)
For t = 0 To 17
msgmsg(i, t) = msg(i, t)
Next
Next i

「nai」配列を利用して追記した配列を上記で作成した「新しい配列」に書き込みます。


Open "CSVファイル指定" For Binary As #1
buf = Space(FileLen("CSVファイル指定"))
Get #1, , buf
Close #1
myName = Split(buf, vbCrLf)

For i = UBound(msg) To UBound(msgmsg)
msg2 = Split(myName(i), ",")
For t = 0 To UBound(msg2)
msgmsg(i, t) = msg2(t)
Next
Next i


Close #1

Open "CSVファイル指定" For Output As #1
i = 0
For i = 0 To UBound(msgmsg)
For j = 0 To 17
Print #1, msgmsg(i, j) & ",";
Next
Print #1,
Next
Close #1

「新しい配列」を書き込みます。

一括名前指定 変更

2017–08–29 (Tue) 14:18
一括名前指定を変更しました。
式が全体的に短くなりました(ファイルを軽くするため)
Counta を使うのも良いですが、重くなるのであまり増減の無いファイル(マクロを実行するにあたって苦にならないファイル)は、
Range().address 又は Cells().addressで指定してしまう方が良いかもしれません。

name Change


Sub 一括名前指定()

Application.Calculation = xlCalculationManual
Dim awb As Workbook
Set awb = ActiveWorkbook
Dim Awbn As Names
Set Awbn = awb.Names
On Error Resume Next

syoz = WorksheetFunction.CountA(Worksheets("住所データ").Range("b:b"))
With Awbn
.Add Name:="その他データ", RefersToR1C1:= _
"=OFFSET(INDIRECT(""その他データ""&""!$c$2""),,,COUNTA(INDIRECT(""その他データ""&""!$c:$c"")),12)"
.Add Name:="一般健診", RefersToR1C1:= _
"=OFFSET(INDIRECT(""一般健康診断個人票""&""!$c$2""),,,COUNTA(INDIRECT(""一般健康診断個人票""&""!$c:$c"")),10)"
.Add Name:="会社データ", RefersToR1C1:= _
"=OFFSET(INDIRECT(""会社データ""&""!$B$2""),,,COUNTA(INDIRECT(""会社データ""&""!$B:$B"")),19)"
.Add Name:="再下請負", RefersToR1C1:= _
"=OFFSET(INDIRECT(""textデータ出力""&""!$A$2""),,,COUNTA(INDIRECT(""textデータ出力""&""!$B:$B"")),20)"
.Add Name:="資格", RefersToR1C1:= _
"=OFFSET(INDIRECT(""資格証全て!""&""$B$2""),,,COUNTA(資格証全て!C1),6)"
.Add Name:="住所データ", RefersTo:="=" & "住所データ!" & Range("c2").Address & ":" & Cells(syoz, 26).Address
.Add Name:="資格取得", RefersTo:="=" & "住所データ!" & Range("c2").Address & ":" & Cells(syoz, 26).Address


.Add Name:="フリガナ", RefersTo:="=" & "住所データ!" & Range("f2").Address & ":" & Range("f" & syoz).Address
.Add Name:="郵便番号", RefersTo:="=" & "住所データ!" & Range("g2").Address & ":" & Range("g" & syoz).Address
.Add Name:="住所", RefersTo:="=" & "住所データ!" & Range("h2").Address & ":" & Range("h" & syoz).Address
.Add Name:="電話番号", RefersTo:="=" & "住所データ!" & Range("i2").Address & ":" & Range("i" & syoz).Address
.Add Name:="緊急連絡先住所", RefersTo:="=" & "住所データ!" & Range("j2").Address & ":" & Range("j" & syoz).Address
.Add Name:="緊急連絡先氏名", RefersTo:="=" & "住所データ!" & Range("k2").Address & ":" & Range("k" & syoz).Address
.Add Name:="緊急連絡先続柄", RefersTo:="=" & "住所データ!" & Range("l2").Address & ":" & Range("l" & syoz).Address
.Add Name:="緊急連絡先電話", RefersTo:="=" & "住所データ!" & Range("m2").Address & ":" & Range("m" & syoz).Address
.Add Name:="職種", RefersTo:="=" & "住所データ!" & Range("n2").Address & ":" & Range("n" & syoz).Address
.Add Name:="入社年月日", RefersTo:="=" & "住所データ!" & Range("o2").Address & ":" & Range("o" & syoz).Address
.Add Name:="経験年数", RefersTo:="=" & "住所データ!" & Range("p2").Address & ":" & Range("p" & syoz).Address
.Add Name:="生年月日", RefersTo:="=" & "住所データ!" & Range("q2").Address & ":" & Range("q" & syoz).Address
.Add Name:="年齢", RefersTo:="=" & "住所データ!" & Range("r2").Address & ":" & Range("r" & syoz).Address
.Add Name:="血液型", RefersTo:="=" & "住所データ!" & Range("s2").Address & ":" & Range("s" & syoz).Address
.Add Name:="雇入時教育", RefersTo:="=" & "住所データ!" & Range("t2").Address & ":" & Range("t" & syoz).Address
.Add Name:="所属会社", RefersTo:="=" & "住所データ!" & Range("b2").Address & ":" & Range("b" & syoz).Address
.Add Name:="氏名", RefersTo:="=" & "住所データ!" & Range("c2").Address & ":" & Range("c" & syoz).Address
.Add Name:="所属会社と氏名", RefersTo:="=" & "住所データ!" & Range("b2").Address & ":" & Range("c" & syoz).Address
.Add Name:="職歴", RefersToR1C1:= _
"=OFFSET(INDIRECT(""職歴全て""&""!$B$2""),,,COUNTA(INDIRECT(""職歴全て""&""!$B:$B"")),5)"
.Add Name:="職歴氏名", RefersToR1C1:= _
"=OFFSET(INDIRECT(""職歴全て""&""!$B$2""),,,COUNTA(INDIRECT(""職歴全て""&""!$B:$B"")))"

a = WorksheetFunction.CountA(Worksheets("社会保険データ").Range("c:c")) + 1
.Add Name:="社会保険", RefersTo:="=" & "社会保険データ!" & Range("c2").Address & ":" & Cells(a, 20).Address
.Add Name:="健康保険種類", RefersTo:="=" & "社会保険データ!" & Range("g2").Address & ":" & Range("g" & a).Address
.Add Name:="健康保険番号", RefersTo:="=" & "社会保険データ!" & Range("h2").Address & ":" & Range("h" & a).Address
.Add Name:="年金種類", RefersTo:="=" & "社会保険データ!" & Range("i2").Address & ":" & Range("i" & a).Address
.Add Name:="年金番号", RefersTo:="=" & "社会保険データ!" & Range("j2").Address & ":" & Range("j" & a).Address
.Add Name:="雇用保険番号", RefersTo:="=" & "社会保険データ!" & Range("k2").Address & ":" & Range("k" & a).Address
.Add Name:="労働契約書", RefersTo:="=" & "社会保険データ!" & Range("l2").Address & ":" & Range("l" & a).Address

.Add Name:="社保取得日", RefersTo:="=" & "社会保険データ!" & Range("m2").Address & ":" & Range("m" & a).Address



.Add Name:="所属会社", RefersTo:="=" & "住所データ!" & Range("b2").Address & ":" & Range("b" & syoz).Address
.Add Name:="氏名", RefersTo:="=" & "住所データ!" & Range("c2").Address & ":" & Range("c" & syoz).Address
.Add Name:="所属会社と氏名", RefersTo:="=" & "住所データ!" & Range("b2").Address & ":" & Range("c" & syoz).Address



.Add Name:="協力会社社員経験チェックシート", RefersToR1C1:= _
"=OFFSET(INDIRECT(""協力会社社員経験チェックシート""&""!$B$6""),,,COUNTA(INDIRECT(""協力会社社員経験チェックシート""&""!$B:$B""))+10,35)"

.Add Name:="運転免許証", RefersToR1C1:= _
"=OFFSET(INDIRECT(""運転免許証""&""!C2""),,,COUNTA(INDIRECT(""運転免許証""&""!$C:$C"")),7)"

.Add Name:="電離検診", RefersToR1C1:= _
"=OFFSET(INDIRECT(""電離検診""&""!$c$2""),,,COUNTA(INDIRECT(""電離検診""&""!$c:$c"")),4)"


End With
Dim Wss As Worksheet
Set Wss = Worksheets("資格証全て")
Dim Wjs As Worksheet
Set Wjs = Worksheets("住所データ")
Dim nyuryokukazu As Integer
nyuryokukazu = 0
For i = 2 To 31
If Wjs.Cells(i, 3) <> "" Then nyuryokukazu = nyuryokukazu + 1
Next

Dim Wjscell As Variant
ReDim Wjscell(nyuryokukazu)

Dim hukazu As Variant
hukazu = Range(Wjs.Range("c2"), Wjs.Cells(nyuryokukazu + 1, 3))
For i = 1 To nyuryokukazu
If nyuryokukazu = 1 Then
Wjscell(i - 1) = hukazu
Else
Wjscell(i - 1) = hukazu(i, 1)
End If
Next

For i = nyuryokukazu + 1 To 30
ken = StrConv(i, vbWide)
For Each nm In awb.Names
If InStr(nm.Name, ken) <> 0 Then
nm.Delete
End If
Next nm
Next

Dim Wsshoku As Worksheet
Set Wsshoku = Worksheets("職歴全て")
With Wsshoku.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
End With
Dim syokureki As Variant
syokureki = Range(Wsshoku.Range("b1"), Wsshoku.Cells(MaxRow, 2))

With Wss.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With

Dim skn As Variant
skn = Range(Wss.Range("b1"), Wss.Cells(MaxRow, 2))
Dim sss As Variant
sss = Range(Wss.Range("c1"), Wss.Cells(MaxRow, 3))





Dim sk As String
sk = "資格証全て!"

For i = 2 To UBound(Wjscell) + 2
On Error Resume Next
If Wjscell(i - 2) <> "" Then
Dim t As Long
t = WorksheetFunction.Match(Wjscell(i - 2), skn, 0)

Dim j As Long

j = WorksheetFunction.CountIf(Range(Wss.Range("b1"), Wss.Cells(MaxRow, 2)), Wjscell(i - 2)) + t - 1

Dim kazu As Long
Dim tatara As String
tatara = StrConv(i - 1, vbWide)
kazu = WorksheetFunction.CountIfs(Range(Wss.Range("b" & j), Wss.Cells(MaxRow, 2)), Wjscell(i - 2), Range(Wss.Range("c" & j), Wss.Cells(MaxRow, 3)), "免")

With Awbn
If kazu <> 0 Then
Dim kosuu As Long
kosuu = kazu
kazu = t + kazu - 1
.Add Name:="免許" & tatara, RefersTo:="=" & sk & Range("D" & j).Address & ":" & Range("G" & kazu).Address
.Add Name:="免許名前" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("D" & kazu).Address
.Add Name:="免許番号" & tatara, RefersTo:="=" & sk & Range("e" & t).Address & ":" & Range("e" & kazu).Address
.Add Name:="免許取得日" & tatara, RefersTo:="=" & sk & Range("f" & t).Address & ":" & Range("f" & kazu).Address
.Add Name:="免許取得先" & tatara, RefersTo:="=" & sk & Range("g" & t).Address & ":" & Range("g" & kazu).Address
t = t + kosuu
Else
For Each nm In awb.Names
If InStr(nm.Name, "免許") <> 0 And InStr(nm.Name, tatara) <> 0 Then
nm.Delete
End If
Next

End If
kazu = 0

On Error Resume Next
kazu = WorksheetFunction.CountIfs(Range(Wss.Range("b" & j), Wss.Cells(MaxRow, 2)), Wjscell(i - 2), Range(Wss.Range("c" & j), Wss.Cells(MaxRow, 3)), "資")

If kazu <> 0 Then
kosuu = kazu
kazu = t + kazu - 1

.Add Name:="資格" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("G" & kazu).Address
.Add Name:="資格名前" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("D" & kazu).Address
.Add Name:="資格番号" & tatara, RefersTo:="=" & sk & Range("e" & t).Address & ":" & Range("e" & kazu).Address
.Add Name:="資格取得日" & tatara, RefersTo:="=" & sk & Range("f" & t).Address & ":" & Range("f" & kazu).Address
.Add Name:="資格取得先" & tatara, RefersTo:="=" & sk & Range("g" & t).Address & ":" & Range("g" & kazu).Address
t = t + kosuu
Else
For Each nm In awb.Names
If InStr(nm.Name, "資格") <> 0 And InStr(nm.Name, tatara) <> 0 Then
nm.Delete
End If
Next
End If

kazu = 0
On Error Resume Next
kazu = WorksheetFunction.CountIfs(Range(Wss.Range("b" & j), Wss.Cells(MaxRow, 2)), Wjscell(i - 2), Range(Wss.Range("c" & j), Wss.Cells(MaxRow, 3)), "特")

If kazu <> 0 Then
kazu = kazu + t - 1
.Add Name:="特別教育" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("G" & kazu).Address
.Add Name:="特別教育名前" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("D" & kazu).Address
.Add Name:="特別教育番号" & tatara, RefersTo:="=" & sk & Range("e" & t).Address & ":" & Range("e" & kazu).Address
.Add Name:="特別教育取得日" & tatara, RefersTo:="=" & sk & Range("f" & t).Address & ":" & Range("f" & kazu).Address
.Add Name:="特別教育取得先" & tatara, RefersTo:="=" & sk & Range("g" & t).Address & ":" & Range("g" & kazu).Address
Else
For Each nm In awb.Names
If InStr(nm.Name, "特別教育") <> 0 And InStr(nm.Name, tatara) <> 0 Then
nm.Delete
End If
Next
End If

End With


sksk = WorksheetFunction.Match(Wjscell(i - 2), syokureki, 0)
kazu = WorksheetFunction.CountIf(Range(Wsshoku.Range("b" & sksk), Wsshoku.Cells(MaxRow, 2)), Wjscell(i - 2)) - 1 + WorksheetFunction.Match(Wjscell(i - 2), syokureki, 0)
If kazu <> 0 Then
tatara = StrConv(i - 1, vbWide)
kazu = kazu
With Awbn
.Add Name:="職歴" & tatara, RefersTo:="=" & "職歴全て!" & Range("C" & sksk).Address & ":" & Range("F" & kazu).Address
.Add Name:="職歴自" & tatara, RefersTo:="=" & "職歴全て!" & Range("C" & sksk).Address & ":" & Range("C" & kazu).Address
.Add Name:="職歴至" & tatara, RefersTo:="=" & "職歴全て!" & Range("d" & sksk).Address & ":" & Range("d" & kazu).Address
.Add Name:="職歴客先名" & tatara, RefersTo:="=" & "職歴全て!" & Range("e" & sksk).Address & ":" & Range("e" & kazu).Address
.Add Name:="職歴件名" & tatara, RefersTo:="=" & "職歴全て!" & Range("F" & sksk).Address & ":" & Range("F" & kazu).Address

End With
End If

End If


Next
Application.Calculation = xlCalculationAutomatic
End Sub

CSVかエクセルか

2017–08–28 (Mon) 09:03
行:1354 列:8

xlsxファイル→101KB
CSVファイル→147KB

作業
1.検索するデータを読み込む
2.XLXLファイル又はCSVファイルを開き読み込む
3.必要なデータを1の指定ワークシートに貼り付ける

xlsxファイルの場合
平均速度 0.89秒
CSVファイルの場合
平均速度 0.033秒

無題

超高速CSV読み込み
Dim myName As Variant, buf As String
Dim msg() As String, t As Long
Open "CSVファイル" For Binary As #1
buf = Space(FileLen("CSVファイル"))
Get #1, , buf
Close #1
myName = Split(buf, vbCrLf)
msg2 = Split(myName(1), ",")
ReDim msg(UBound(myName), Ubound(msg2 ))
For i = 0 To UBound(myName)
msg2 = Split(myName(i), ",")
For t = 0 To UBound(msg2)
msg(i, t) = msg2(t)
Next
Next i

"CSVファイル"にCSVファイルのアドレスを入れます。

CSV を読み込む

2017–08–27 (Sun) 18:47
Sub CSVを使用する()
'CSVを配列に代入します

Dim b_buf() As Byte, s_buf As String
Const TARGET As String = "C:\Users\ownar\Desktop\Book1.csv"

Open TARGET For Binary As #1
ReDim b_buf(1 To LOF(1))
Get #1, , b_buf
s_buf = StrConv(b_buf, vbUnicode)
Dim nyuryoku As Variant
nyuryoku = Split(s_buf, vbCrLf)
kazu = Split(nyuryoku(0), ",")
Dim nyuryoku2() As String
ReDim nyuryoku2(UBound(nyuryoku), UBound(kazu))
Close #1

For j = 1 To UBound(nyuryoku)
kazu = Split(nyuryoku(j), ",")
For i = 1 To UBound(kazu)
nyuryoku2(j, i) = kazu(i)
Next
Next

End Sub

CSVから配列に代入してくれます。
今までExcelファイルを開いていたものをいくつかcsvに変更したら凄く処理速度が速くなりました!
一つのファイルでも0.5~1秒くらいは余裕で短縮できます♪

藤田麻衣子さんのライブに行きたい。。。

一括名前指定 修正版

2017–08–25 (Fri) 13:56
エクセルマクロ「一括名前指定」を変更したので公開致します。

Sub 一括名前指定()

Application.Calculation = xlCalculationManual
Dim awb As Workbook
Set awb = ActiveWorkbook
Dim Awbn As Names
Set Awbn = awb.Names
On Error Resume Next

With Awbn
.Add Name:="その他データ", RefersToR1C1:= _
"=OFFSET(INDIRECT(""その他データ""&""!$c$2""),,,COUNTA(INDIRECT(""その他データ""&""!$c:$c"")),12)"
.Add Name:="一般健診", RefersToR1C1:= _
"=OFFSET(INDIRECT(""一般健康診断個人票""&""!$c$2""),,,COUNTA(INDIRECT(""一般健康診断個人票""&""!$c:$c"")),10)"
.Add Name:="会社データ", RefersToR1C1:= _
"=OFFSET(INDIRECT(""会社データ""&""!$B$2""),,,COUNTA(INDIRECT(""会社データ""&""!$B:$B"")),19)"
.Add Name:="再下請負", RefersToR1C1:= _
"=OFFSET(INDIRECT(""textデータ出力""&""!$A$2""),,,COUNTA(INDIRECT(""textデータ出力""&""!$B:$B"")),20)"
.Add Name:="資格", RefersToR1C1:= _
"=OFFSET(INDIRECT(""資格証全て!""&""$B$2""),,,COUNTA(資格証全て!C1),6)"
.Add Name:="住所データ", RefersToR1C1:="=INDIRECT(""住所データ""&""!$C$2:$AB$31"")"
.Add Name:="フリガナ", RefersToR1C1:="=INDIRECT(""住所データ""&""!$f$2:$f$31"")"
.Add Name:="郵便番号", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$g$2:$g$31"")"
.Add Name:="住所", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$h$2:$h$31"")"
.Add Name:="電話番号", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$i$2:$i$31"")"
.Add Name:="緊急連絡先住所", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$j$2:$j$31"")"
.Add Name:="緊急連絡先氏名", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$k$2:$k$31"")"
.Add Name:="緊急連絡先続柄", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$l$2:$l$31"")"
.Add Name:="緊急連絡先電話", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$m$2:$m$31"")"
.Add Name:="職種", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$n$2:$n$31"")"
.Add Name:="入社年月日", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$o$2:$o$31"")"
.Add Name:="経験年数", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$p$2:$p$31"")"
.Add Name:="生年月日", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$q$2:$q$31"")"
.Add Name:="年齢", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$r$2:$r$31"")"
.Add Name:="血液型", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$s$2:$s$31"")"
.Add Name:="雇入時教育", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$t$2:$t$31"")"
.Add Name:="職歴", RefersToR1C1:= _
"=OFFSET(INDIRECT(""職歴全て""&""!$B$2""),,,COUNTA(INDIRECT(""職歴全て""&""!$B:$B"")),5)"
.Add Name:="職歴氏名", RefersToR1C1:= _
"=OFFSET(INDIRECT(""職歴全て""&""!$B$2""),,,COUNTA(INDIRECT(""職歴全て""&""!$B:$B"")))"

.Add Name:="社会保険", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$c$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")),20)"

.Add Name:="健康保険種類", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$g$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$B:$B"")),)"

.Add Name:="健康保険番号", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$h$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")),)"

.Add Name:="年金種類", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$i$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")))"

.Add Name:="年金番号", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$j$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")))"

.Add Name:="雇用保険番号", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$k$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")))"

.Add Name:="労働契約書", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$l$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")))"

.Add Name:="社保取得日", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$m$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")))"

.Add Name:="所属会社", RefersToR1C1:= _
"=OFFSET(INDIRECT(""住所データ""&""!$B$2""),,,COUNTA(INDIRECT(""住所データ""&""!$B:$B"")))"

.Add Name:="氏名", RefersToR1C1:= _
"=OFFSET(INDIRECT(""住所データ""&""!$c$2""),,,COUNTA(INDIRECT(""住所データ""&""!$c:$c"")))"

.Add Name:="所属会社と氏名", RefersToR1C1:= _
"=OFFSET(INDIRECT(""住所データ""&""!$b$2""),,,COUNTA(INDIRECT(""住所データ""&""!$c:$c"")),2)"

.Add Name:="資格取得", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$C$2:$AB$31"")"

.Add Name:="協力会社社員経験チェックシート", RefersToR1C1:= _
"=OFFSET(INDIRECT(""協力会社社員経験チェックシート""&""!$B$6""),,,COUNTA(INDIRECT(""協力会社社員経験チェ ックシート""&""!$B:$B""))+10,35)"

.Add Name:="運転免許証", RefersToR1C1:= _
"=OFFSET(INDIRECT(""運転免許証""&""!C2""),,,COUNTA(INDIRECT(""運転免許証""&""!$C:$C"")),7)"

.Add Name:="電離検診", RefersToR1C1:= _
"=OFFSET(INDIRECT(""電離検診""&""!$c$2""),,,COUNTA(INDIRECT(""電離検診""&""!$c:$c"")),4)"


End With
Dim Wss As Worksheet
Set Wss = Worksheets("資格証全て")
Dim Wjs As Worksheet
Set Wjs = Worksheets("住所データ")
Dim nyuryokukazu As Integer
nyuryokukazu = 0
For i = 2 To 31
If Wjs.Cells(i, 3) <> "" Then nyuryokukazu = nyuryokukazu + 1
Next

Dim Wjscell As Variant
ReDim Wjscell(nyuryokukazu)

Dim hukazu As Variant
hukazu = Range(Wjs.Range("c2"), Wjs.Cells(nyuryokukazu + 1, 3))
For i = 1 To nyuryokukazu
Wjscell(i - 1) = hukazu(i, 1)
Next

For i = nyuryokukazu + 1 To 30
ken = StrConv(i, vbWide)
For Each nm In ActiveWorkbook.Names
If InStr(nm.Name, ken) <> 0 Then
nm.Delete
End If
Next nm
Next

With Wss.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With

Dim skn As Variant
skn = Range(Wss.Range("b1"), Wss.Cells(MaxRow, 2))
Dim sss As Variant
sss = Range(Wss.Range("c1"), Wss.Cells(MaxRow, 3))



Dim sk As String
sk = "資格証全て!"

For i = 2 To UBound(Wjscell) + 2
On Error Resume Next
If Wjscell(i - 2) <> "" Then
Dim t As Long
t = WorksheetFunction.Match(Wjscell(i - 2), skn, 0)

Dim j As Long

j = WorksheetFunction.CountIf(Range(Wss.Range("b1"), Wss.Cells(MaxRow, 2)), Wjscell(i - 2)) + t - 1

Dim kazu As Long
Dim tatara As String
tatara = StrConv(i - 1, vbWide)
kazu = WorksheetFunction.CountIfs(Range(Wss.Range("b1"), Wss.Cells(MaxRow, 2)), Wjscell(i - 2), Range(Wss.Range("c1"), Wss.Cells(MaxRow, 3)), "免")

With Awbn
If kazu <> 0 Then
Dim kosuu As Long
kosuu = kazu
kazu = t + kazu - 1
.Add Name:="免許" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("G" & kazu).Address
.Add Name:="免許名前" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("D" & kazu).Address
.Add Name:="免許番号" & tatara, RefersTo:="=" & sk & Range("e" & t).Address & ":" & Range("e" & kazu).Address
.Add Name:="免許取得日" & tatara, RefersTo:="=" & sk & Range("f" & t).Address & ":" & Range("f" & kazu).Address
.Add Name:="免許取得先" & tatara, RefersTo:="=" & sk & Range("g" & t).Address & ":" & Range("g" & kazu).Address
t = t + kosuu
End If
kazu = 0

On Error Resume Next
kazu = WorksheetFunction.CountIfs(Range(Wss.Range("b1"), Wss.Cells(MaxRow, 2)), Wjscell(i - 2), Range(Wss.Range("c1"), Wss.Cells(MaxRow, 3)), "資")

If kazu <> 0 Then
kosuu = kazu
kazu = t + kazu - 1

.Add Name:="資格" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("G" & kazu).Address
.Add Name:="資格名前" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("D" & kazu).Address
.Add Name:="資格番号" & tatara, RefersTo:="=" & sk & Range("e" & t).Address & ":" & Range("e" & kazu).Address
.Add Name:="資格取得日" & tatara, RefersTo:="=" & sk & Range("f" & t).Address & ":" & Range("f" & kazu).Address
.Add Name:="資格取得先" & tatara, RefersTo:="=" & sk & Range("g" & t).Address & ":" & Range("g" & kazu).Address
t = t + kosuu
End If
kazu = 0
On Error Resume Next
kazu = WorksheetFunction.CountIfs(Range(Wss.Range("b1"), Wss.Cells(MaxRow, 2)), Wjscell(i - 2), Range(Wss.Range("c1"), Wss.Cells(MaxRow, 3)), "特")

If kazu <> 0 Then
kazu = kazu + t - 1
.Add Name:="特別教育" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("G" & kazu).Address
.Add Name:="特別教育名前" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("D" & kazu).Address
.Add Name:="特別教育番号" & tatara, RefersTo:="=" & sk & Range("e" & t).Address & ":" & Range("e" & kazu).Address
.Add Name:="特別教育取得日" & tatara, RefersTo:="=" & sk & Range("f" & t).Address & ":" & Range("f" & kazu).Address
.Add Name:="特別教育取得先" & tatara, RefersTo:="=" & sk & Range("g" & t).Address & ":" & Range("g" & kazu).Address
End If
End With
End If
Next

Dim Wsshoku As Worksheet
Set Wsshoku = Worksheets("職歴全て")
With Wsshoku.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
End With
Dim syokureki As Variant
syokureki = Range(Wsshoku.Range("b1"), Wsshoku.Cells(MaxRow, 2))


For i = 2 To UBound(Wjscell) + 2
On Error Resume Next
If Wjscell(i - 2) <> "" Then
t = WorksheetFunction.Match(Wjscell(i - 2), syokureki, 0)
kazu = WorksheetFunction.CountIf(Range(Wsshoku.Range("b1"), Wsshoku.Cells(MaxRow, 2)), Wjscell(i - 2)) - 1 + WorksheetFunction.Match(Wjscell(i - 2), syokureki, 0)
If kazu <> 0 Then
tatara = StrConv(i - 1, vbWide)
With Awbn
.Add Name:="職歴" & tatara, RefersTo:="=" & "職歴全て!" & Range("C" & t).Address & ":" & Range("F" & kazu).Address
.Add Name:="職歴自" & tatara, RefersTo:="=" & "職歴全て!" & Range("C" & t).Address & ":" & Range("C" & kazu).Address
.Add Name:="職歴至" & tatara, RefersTo:="=" & "職歴全て!" & Range("d" & t).Address & ":" & Range("d" & kazu).Address
.Add Name:="職歴客先名" & tatara, RefersTo:="=" & "職歴全て!" & Range("e" & t).Address & ":" & Range("e" & kazu).Address
.Add Name:="職歴件名" & tatara, RefersTo:="=" & "職歴全て!" & Range("F" & t).Address & ":" & Range("F" & kazu).Address

End With
End If
End If

Next
For i = nyuryokukazu To 30
ken = StrConv(i, vbWide)
For Each nm In ActiveWorkbook.Names
If nm.RefersTo = "" Then
nm.Delete
End If
Next nm
Next
Application.Calculation = xlCalculationAutomatic
End Sub


今回前回
0.460.85
0.470.85
0.470.79
0.470.85
0.480.79
0.480.79
0.480.79
0.480.85
0.480.86
0.480.79
0.4750.821


平均して0.346秒短くなりました。

一括名前設定更新

2017–08–22 (Tue) 14:30
以前公開した「一括名前指定」の高速版を作りましたので公開致します。
2秒ぐらい早くなり、平均速度が0.1秒を切っています。

Sub 一括名前指定()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
Dim awb As Workbook
Set awb = ActiveWorkbook
Dim Awbn As Names
Set Awbn = awb.Names
On Error Resume Next
Awbn.Names.Item("その他データ").Delete
Awbn.Add Name:="その他データ", RefersToR1C1:= _
"=OFFSET(INDIRECT(""その他データ""&""!$c$2""),,,COUNTA(INDIRECT(""その他データ""&""!$c:$c"")),12)"

Awbn.Item("一般健診").Delete
Awbn.Add Name:="一般健診", RefersToR1C1:= _
"=OFFSET(INDIRECT(""一般健康診断個人票""&""!$c$2""),,,COUNTA(INDIRECT(""一般健康診断個人票""&""!$c:$c"")),10)"

Awbn.Item("会社データ").Delete
Awbn.Add Name:="会社データ", RefersToR1C1:= _
"=OFFSET(INDIRECT(""会社データ""&""!$B$2""),,,COUNTA(INDIRECT(""会社データ""&""!$B:$B"")),19)"

Awbn.Item("再下請負").Delete
Awbn.Add Name:="再下請負", RefersToR1C1:= _
"=OFFSET(INDIRECT(""textデータ出力""&""!$A$2""),,,COUNTA(INDIRECT(""textデータ出力""&""!$B:$B"")),20)"

Awbn.Item("資格").Delete
Awbn.Add Name:="資格", RefersToR1C1:= _
"=OFFSET(INDIRECT(""資格証全て!""&""$B$2""),,,COUNTA(資格証全て!C1),6)"

Awbn.Item("住所データ").Delete
Awbn.Add Name:="住所データ", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$C$2:$AB$31"")"

Awbn.Item("フリガナ").Delete
Awbn.Add Name:="フリガナ", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$f$2:$f$31"")"

Awbn.Item("郵便番号").Delete
Awbn.Add Name:="郵便番号", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$g$2:$g$31"")"

Awbn.Add Name:="住所", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$h$2:$h$31"")"

Awbn.Add Name:="電話番号", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$i$2:$i$31"")"

Awbn.Add Name:="緊急連絡先住所", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$j$2:$j$31"")"

Awbn.Add Name:="緊急連絡先氏名", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$k$2:$k$31"")"

Awbn.Add Name:="緊急連絡先続柄", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$l$2:$l$31"")"

Awbn.Add Name:="緊急連絡先電話", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$m$2:$m$31"")"

Awbn.Add Name:="職種", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$n$2:$n$31"")"

Awbn.Add Name:="入社年月日", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$o$2:$o$31"")"

Awbn.Add Name:="経験年数", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$p$2:$p$31"")"

Awbn.Add Name:="生年月日", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$q$2:$q$31"")"

Awbn.Add Name:="年齢", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$r$2:$r$31"")"

Awbn.Add Name:="血液型", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$s$2:$s$31"")"

Awbn.Add Name:="雇入時教育", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$t$2:$t$31"")"

Awbn.Add Name:="職歴", RefersToR1C1:= _
"=OFFSET(INDIRECT(""職歴全て""&""!$B$2""),,,COUNTA(INDIRECT(""職歴全て""&""!$B:$B"")),5)"

Awbn.Add Name:="職歴氏名", RefersToR1C1:= _
"=OFFSET(INDIRECT(""職歴全て""&""!$B$2""),,,COUNTA(INDIRECT(""職歴全て""&""!$B:$B"")))"

Awbn.Add Name:="社会保険", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$c$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")),20)"

Awbn.Add Name:="健康保険種類", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$g$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$B:$B"")),)"

Awbn.Add Name:="健康保険番号", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$h$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")),)"

Awbn.Add Name:="年金種類", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$i$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")))"

Awbn.Add Name:="年金番号", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$j$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")))"

Awbn.Add Name:="雇用保険番号", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$k$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")))"

Awbn.Add Name:="労働契約書", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$l$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")))"

Awbn.Add Name:="社保取得日", RefersToR1C1:= _
"=OFFSET(INDIRECT(""社会保険データ""&""!$m$2""),,,COUNTA(INDIRECT(""社会保険データ""&""!$c:$c"")))"

Awbn.Add Name:="所属会社", RefersToR1C1:= _
"=OFFSET(INDIRECT(""住所データ""&""!$B$2""),,,COUNTA(INDIRECT(""住所データ""&""!$B:$B"")))"

Awbn.Add Name:="氏名", RefersToR1C1:= _
"=OFFSET(INDIRECT(""住所データ""&""!$c$2""),,,COUNTA(INDIRECT(""住所データ""&""!$c:$c"")))"

Awbn.Add Name:="所属会社と氏名", RefersToR1C1:= _
"=OFFSET(INDIRECT(""住所データ""&""!$b$2""),,,COUNTA(INDIRECT(""住所データ""&""!$c:$c"")),2)"

Awbn.Add Name:="資格取得", RefersToR1C1:= _
"=INDIRECT(""住所データ""&""!$C$2:$AB$31"")"

Awbn.Add Name:="協力会社社員経験チェックシート", RefersToR1C1:= _
"=OFFSET(INDIRECT(""協力会社社員経験チェックシート""&""!$B$6""),,,COUNTA(INDIRECT(""協力会社社員経験チェ ックシート""&""!$B:$B""))+10,35)"

Awbn.Add Name:="運転免許証", RefersToR1C1:= _
"=OFFSET(INDIRECT(""運転免許証""&""!C2""),,,COUNTA(INDIRECT(""運転免許証""&""!$C:$C"")),7)"

Awbn.Add Name:="電離検診", RefersToR1C1:= _
"=OFFSET(INDIRECT(""電離検診""&""!$c$2""),,,COUNTA(INDIRECT(""電離検診""&""!$c:$c"")),4)"
On Error GoTo 0


For i = 1 To 30
On Error Resume Next
Awbn.Item("免許" & StrConv(i, vbWide)).Delete
Awbn.Item("免許名前" & StrConv(i, vbWide)).Delete
Awbn.Item("免許番号" & StrConv(i, vbWide)).Delete
Awbn.Item("免許取得日" & StrConv(i, vbWide)).Delete
Awbn.Item("免許取得先" & StrConv(i, vbWide)).Delete
Awbn.Item("資格" & StrConv(i, vbWide)).Delete
Awbn.Item("資格名前" & StrConv(i, vbWide)).Delete
Awbn.Item("資格番号" & StrConv(i, vbWide)).Delete
Awbn.Item("資格取得日" & StrConv(i, vbWide)).Delete
Awbn.Item("資格取得先" & StrConv(i, vbWide)).Delete
Awbn.Item("特別教育" & StrConv(i, vbWide)).Delete
Awbn.Item("特別教育名前" & StrConv(i, vbWide)).Delete
Awbn.Item("特別教育番号" & StrConv(i, vbWide)).Delete
Awbn.Item("特別教育取得日" & StrConv(i, vbWide)).Delete
Awbn.Item("特別教育取得先" & StrConv(i, vbWide)).Delete
Awbn.Item("職歴" & StrConv(i, vbWide)).Delete
Awbn.Item("職歴自" & StrConv(i, vbWide)).Delete
Awbn.Item("職歴至" & StrConv(i, vbWide)).Delete
Awbn.Item("職歴客先名" & StrConv(i, vbWide)).Delete
Awbn.Item("職歴件名" & StrConv(i, vbWide)).Delete
On Error GoTo 0
Next
Dim Wss As Worksheet
Set Wss = Worksheets("資格証全て")
Dim Wjs As Worksheet
Set Wjs = Worksheets("住所データ")

Dim Wjscell As Variant
ReDim Wjscell(29)
Dim hukazu As Variant
hukazu = Wjs.Range("c2:c31")
For i = 1 To 30
If hukazu(i, 1) <> "" Then
Wjscell(i - 1) = hukazu(i, 1)
Else
Exit For
End If
Next
With Wss.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With

Dim skn As Variant
skn = Range(Wss.Range("b1"), Wss.Cells(MaxRow, 2))
Dim sss As Variant
sss = Range(Wss.Range("c1"), Wss.Cells(MaxRow, 3))
Dim sk As String
sk = "資格証全て!"

For i = 2 To UBound(Wjscell) + 2
On Error Resume Next
If Wjscell(i - 2) <> "" Then
Dim t As Long
t = 2
Do Until skn(t, 1) = Wjscell(i - 2)
t = t + 1
Loop
Dim j As Long
j = t
Do While skn(j, 1) = Wjscell(i - 2)
If IsEmpty(skn(j, 1)) = True Then
Exit Do
End If
j = j + 1
Loop
Dim kazu As Long
kazu = 0
j = j - 1
For s = t To j
If sss(s, 1) = "免" Then
kazu = kazu + 1
End If
Next
If kazu <> 0 Then
Dim kosuu As Long
kosuu = kazu
kazu = t + kazu - 1
Awbn.Add Name:="免許" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("D" & kazu).Address & ":" & Range("G" & kazu).Address
Awbn.Add Name:="免許名前" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("D" & kazu).Address & ":" & Range("D" & kazu).Address
Awbn.Add Name:="免許番号" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("e" & kazu).Address & ":" & Range("e" & kazu).Address
Awbn.Add Name:="免許取得日" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("f" & kazu).Address & ":" & Range("f" & kazu).Address
Awbn.Add Name:="免許取得先" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("g" & kazu).Address & ":" & Range("g" & kazu).Address
t = t + kosuu
End If


ngAddress = ""
kazu = 0
kensaku = 0

On Error Resume Next
For s = t To j
If sss(s, 1) = "資" Then
kazu = kazu + 1
End If
Next
If kazu <> 0 Then
kosuu = kazu
kazu = t + kazu - 1
Awbn.Add Name:="資格" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("G" & kazu).Address
Awbn.Add Name:="資格名前" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("D" & kazu).Address
Awbn.Add Name:="資格番号" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("e" & t).Address & ":" & Range("e" & kazu).Address
Awbn.Add Name:="資格取得日" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("f" & t).Address & ":" & Range("f" & kazu).Address
Awbn.Add Name:="資格取得先" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("g" & t).Address & ":" & Range("g" & kazu).Address
t = t + kosuu
End If

kazu = 0
kaishi = 0
kensaku = 0


On Error Resume Next
For s = t To j
If sss(s, 1) = "特" Then
kazu = kazu + 1
End If
Next
If kazu <> 0 Then
kosuu = kazu
kazu = t + kazu - 1
Awbn.Add Name:="特別教育" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("G" & kazu).Address
Awbn.Add Name:="特別教育名前" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("D" & kazu).Address
Awbn.Add Name:="特別教育番号" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("e" & t).Address & ":" & Range("e" & kazu).Address
Awbn.Add Name:="特別教育取得日" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("f" & t).Address & ":" & Range("f" & kazu).Address
Awbn.Add Name:="特別教育取得先" & StrConv(i - 1, vbWide), RefersTo:="=" & sk & Range("g" & t).Address & ":" & Range("g" & kazu).Address
t = t + kosuu
End If
End If
rngAddress = ""
kazu = 0
kaishi = 0
kensaku = 0
tokukazu = 0
menkazu = 0
yousetsu = 0
shikazu = 0
Next
Dim Wsshoku As Worksheet
Set Wsshoku = Worksheets("職歴全て")
With Wsshoku.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
Dim syokureki As Variant
syokureki = Range(Wsshoku.Range("b1"), Cells(MaxRow, 2))


For i = 2 To UBound(Wjscell) + 2
On Error Resume Next
If Wjscell(i - 2) <> "" Then

t = 2
Do Until syokureki(t, 1) = Wjscell(i - 2)
If IsEmpty(syokureki(t, 1)) = True Then
t = t - 1
Exit Do
End If
t = t + 1
Loop
j = t
Do While syokureki(j, 1) = Wjscell(i - 2)
If IsEmpty(syokureki(j, 1)) = True Then
Exit Do
End If

j = j + 1
kazu = kazu + 1
Loop
j = j - 1

If kazu <> 0 Then
kosuu = kazu
kazu = t + kazu - 1
Awbn.Add Name:="職歴" & StrConv(i - 1, vbWide), RefersTo:="=" & "職歴全て!" & Range("C" & t).Address & ":" & Range("F" & j).Address
Awbn.Add Name:="職歴自" & StrConv(i - 1, vbWide), RefersTo:="=" & "職歴全て!" & Range("C" & t).Address & ":" & Range("C" & j).Address
Awbn.Add Name:="職歴至" & StrConv(i - 1, vbWide), RefersTo:="=" & "職歴全て!" & Range("d" & t).Address & ":" & Range("d" & j).Address
Awbn.Add Name:="職歴客先名" & StrConv(i - 1, vbWide), RefersTo:="=" & "職歴全て!" & Range("e" & t).Address & ":" & Range("e" & j).Address
Awbn.Add Name:="職歴件名" & StrConv(i - 1, vbWide), RefersTo:="=" & "職歴全て!" & Range("F" & t).Address & ":" & Range("F" & j).Address
t = t + kosuu
End If
kazu = 0
End If
Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
End Sub

付箋マクロ

2017–08–21 (Mon) 22:33
新しい付箋マクロです。
以前より早くなりました。

Fusen.xlsm

少し変更したのです。
そうしたら0.1秒切りました。
これからもっと0.1秒切っていきたいです。






幽々子様の弾幕美しい……はぁ……(プレイは結構大変です)

箇条書きマクロ

2017–08–18 (Fri) 22:38
箇条書きマクロ 配列版です。
もっと早くなると思いますがとりあえずこの辺で……。

Public kensaku(14) As String
Sub Macro1()
If kensaku(0) = "" Then
kensaku(0) = "・"
kensaku(1) = "●"
kensaku(2) = "○"
kensaku(3) = "◆"
kensaku(4) = "◇"
kensaku(5) = "▼"
kensaku(6) = "▽"
kensaku(7) = "▲"
kensaku(8) = "△"
kensaku(9) = "□"
kensaku(10) = "■"
kensaku(11) = "※"
kensaku(12) = "◎"
kensaku(13) = "☆"
kensaku(14) = "★"
End If
End Sub

Sub 中点指定無し()
Call Macro1
Dim nai As Integer
Dim basyo As Variant
basyo = Selection
Dim RC As Long
RC = UBound(basyo)
Dim Cc As Long
Cc = UBound(basyo, 2)
For i = 1 To RC
For j = 1 To Cc
nai = 0
shiraberu = basyo(i, j)
For t = 0 To 14
If shiraberu = kensaku(t) Then
nai = 0
basyo(i, j) = Replace(basyo(i, j), shiraberu, "○")
Exit For
Else
nai = 1
End If
Next
If nai = 1 Then
basyo(i, j) = "○" & basyo(i, j)
End If
Next
Next
Selection = basyo
End Sub

和暦曜日有り

2017–08–15 (Tue) 21:04
和暦曜日有りの単語登録です。
単語登録一杯作りました。

和暦曜日有り.txt

へ118平成1年1月8日(日)独立語
へ119平成1年1月9日(月)独立語
へ1110平成1年1月10日(火)独立語
へ1111平成1年1月11日(水)独立語
へ1112平成1年1月12日(木)独立語
へ1113平成1年1月13日(金)独立語
へ1114平成1年1月14日(土)独立語
へ1115平成1年1月15日(日)独立語
へ1116平成1年1月16日(月)独立語
へ1117平成1年1月17日(火)独立語
へ1118平成1年1月18日(水)独立語
へ1119平成1年1月19日(木)独立語
へ1120平成1年1月20日(金)独立語
へ1121平成1年1月21日(土)独立語
へ1122平成1年1月22日(日)独立語
へ1123平成1年1月23日(月)独立語
へ1124平成1年1月24日(火)独立語
へ1125平成1年1月25日(水)独立語
へ1126平成1年1月26日(木)独立語
へ1127平成1年1月27日(金)独立語
へ1128平成1年1月28日(土)独立語
へ1129平成1年1月29日(日)独立語
へ1130平成1年1月30日(月)独立語
へ1131平成1年1月31日(火)独立語


次からは趣味の単語登録作ります~。
お金にもなるし!!!

 | HOME |  次へ »

プロフィール

あゆみ

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

最新記事

最新コメント

フリーエリア

月別アーカイブ

カテゴリ

ブロとも申請フォーム

検索フォーム

RSSリンクの表示

リンク