FC2ブログ

一括名前指定 修正版

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秒短くなりました。
スポンサーサイト



« 一括名前設定更新 | HOME |  CSV を読み込む »

コメント

コメントの投稿

 
管理者にだけ表示

 | HOME | 

プロフィール

はる

Author:はる
FC2ブログへようこそ!

最新記事

最新コメント

フリーエリア

月別アーカイブ

カテゴリ

ブロとも申請フォーム

検索フォーム

RSSリンクの表示

リンク