以下のコードで「入力」シートのデータから「DB]シートに登録するんです。「DB」シートの一行目A1は題名ですが新しいデータに入ってくるとどんどん題名は下の行に下がっていく。
題名は固定し、新しいデータはA2から入ってくるようにしたいですがどこに変更すればいいかわからなくて困っています。（ExcelのVBAはまったくわかりません）
よろしくお願いします。
Excel 2007
Sub 登録_Click()
'On Error GoTo Err_登録
Dim n As Integer '入力明細の数
Dim x As Long 'DBの検索範囲の最終行
Dim rng As Range '検索したセル
Dim z As Long 'DBのデータの最終行
Dim tbl As Worksheet '[ＤＢ]シート
Dim key As String '検索キー
Dim from_key As Long '更新範囲（自）
Dim to_key As Long '更新範囲（至）
'警告メッセージ非表示
Application.ScreenUpdating = False
Worksheets("入力").Activate
Set tbl = Sheets("ＤＢ")
z = tbl.Range("A1").CurrentRegion.Rows.Count
Check_登録:
key = Range("B2").Value
If key = "" Then
MsgBox "発注番号が未入力です。"
Exit Sub
End If
'[発注番号]でソート
tbl.Range("A1").Sort Key1:=tbl.Range("A1"), Header:=xlGuess
'存在チェック
x = tbl.Range("A1").End(xlDown).Row
With tbl.Range("A1:A" & x)
Set rng = .Find(key, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
MsgBox "既存の番号が存在します。"
Exit Sub
End If
End With
'明細行有無チェック
n = WorksheetFunction.CountIf(Range("M46:M65"), "*")
If n = 0 Then
MsgBox "明細行がありません。"
Exit Sub
End If
Add_登録:
'空白行を省く
Selection.AutoFilter Field:=14, Criteria1:="<>"
'コピー&貼り付け
Range("A47:U66").Copy
tbl.Range("A" & z + 1).PasteSpecial Paste:=xlPasteValues
'[発注番号]でソート
tbl.Range("A1").Sort Key1:=tbl.Range("A1"), Header:=xlGuess
'コピーモード解除
Application.CutCopyMode = False
'空白行を省くを解除
Selection.AutoFilter Field:=14
'ブック保存
'ActiveWorkbook.Save
'画面クリア
Call 画面クリア
'警告メッセージ表示
Application.ScreenUpdating = True
Exit_登録:
MsgBox "登録しました。"
Exit Sub
Err_登録:
MsgBox "エラーが発生しました
以下のコードで「入力」シートのデータから「DB]シートに登録するんです。「DB」シートの一行目A1は題名ですが新しいデータに入ってくるとどんどん題名は下の行に下がっていく。
題名は固定し、新しいデータはA2から入ってくるようにしたいですがどこに変更すればいいかわからなくて困っています。（ExcelのVBAはまったくわかりません）
よろしくお願いします。
Excel 2007
Sub 登録_Click()
'On Error GoTo Err_登録
Dim n As Integer '入力明細の数
Dim x As Long 'DBの検索範囲の最終行
Dim rng As Range '検索したセル
Dim z As Long 'DBのデータの最終行
Dim tbl As Worksheet '[ＤＢ]シート
Dim key As String '検索キー
Dim from_key As Long '更新範囲（自）
Dim to_key As Long '更新範囲（至）
'警告メッセージ非表示
Application.ScreenUpdating = False
Worksheets("入力").Activate
Set tbl = Sheets("ＤＢ")
z = tbl.Range("A1").CurrentRegion.Rows.Count
Check_登録:
key = Range("B2").Value
If key = "" Then
MsgBox "発注番号が未入力です。"
Exit Sub
End If
'[発注番号]でソート
tbl.Range("A1").Sort Key1:=tbl.Range("A1"), Header:=xlGuess
'存在チェック
x = tbl.Range("A1").End(xlDown).Row
With tbl.Range("A1:A" & x)
Set rng = .Find(key, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
MsgBox "既存の番号が存在します。"
Exit Sub
End If
End With
'明細行有無チェック
n = WorksheetFunction.CountIf(Range("M46:M65"), "*")
If n = 0 Then
MsgBox "明細行がありません。"
Exit Sub
End If
Add_登録:
'空白行を省く
Selection.AutoFilter Field:=14, Criteria1:="<>"
'コピー&貼り付け
Range("A47:U66").Copy
tbl.Range("A" & z + 1).PasteSpecial Paste:=xlPasteValues
'[発注番号]でソート
tbl.Range("A1").Sort Key1:=tbl.Range("A1"), Header:=xlGuess
'コピーモード解除
Application.CutCopyMode = False
'空白行を省くを解除
Selection.AutoFilter Field:=14
'ブック保存
'ActiveWorkbook.Save
'画面クリア
Call 画面クリア
'警告メッセージ表示
Application.ScreenUpdating = True
Exit_登録:
MsgBox "登録しました。"
Exit Sub
Err_登録:
MsgBox "エラーが発生しました
【Excel VBA】A列の全角・半角文字をチェック
Excel VBAの初心者です。
仕事で必要なため、教えていただけると助かります。
【やりたいこと】
Excel VBAで、入力が完了したExcelシートのA列(A1からA10)が、
半角のみであること、または全角が入力されていないこと、を
チェックしたいです。
半角以外の文字があった場合は、メッセージを表示します。
また、半角以外のセルがあった場合は、そのセルの色を水色にします。
入力チェックの方法は、ボタンにマクロを登録して、
そのボタンを押下することで行います。
以下に、僕が試したプログラムを記します。
アドバイスをいただけると幸いです。よろしくお願いします。
Sub 入力チェック()
Dim cellValue As String
Dim strANSI As String
Dim i As Integer
For i = 0 To 10
cellValue = Cells(1, i + 1)
strANSI = StrConv(cellValue, vbFromUnicode)
If Len(cellValue) = LenB(strANSI) Then
MsgBox "セルは半角のみ"
myColor = 8
Else
MsgBox "セルの内容は全角のみ"
End If
MsgBox "セルの内容は全角と半角があり"
Next i
End Sub
エクセルVBA 重複を表示したい
Ａ列で重複すると警告するコードを以下のように作成しました。
これを修正してＡ列で重複して、なおかつＢ列でも重複した場合警告するコードにしたいのです。
添付した図では「同姓同名あり、確認してください、鈴木一郎、山口」と表示したいのです。
ご教授よろしくお願いします。
Sub test()
Dim myRange As Range
Dim 同一flag As Boolean
Dim MsgStr As String
For Each myRange In Range("A2:A10")
If WorksheetFunction.CountIf(Range("A2:A10"), myRange) > 1 Then
If 同一flag = False Then 同一flag = True
If InStr(1, MsgStr, myRange) = 0 Then
MsgStr = MsgStr & myRange & vbCrLf
End If
End If
Next
If 同一flag = True Then
MsgBox "同姓同名あり" & Chr(13) & _
"確認してください" & Chr(13) & _
vbCrLf & MsgStr
Else
End If
End Sub
エクセルVBA 重複を表示したい
Ａ列で重複すると警告するコードを以下のように作成しました。
これを修正してＡ列で重複して、なおかつＢ列でも重複した場合警告するコードにしたいのです。
添付した図では「同姓同名あり、確認してください、鈴木一郎、山口」と表示したいのです。
ご教授よろしくお願いします。
Sub test()
Dim myRange As Range
Dim 同一flag As Boolean
Dim MsgStr As String
For Each myRange In Range("A2:A10")
If WorksheetFunction.CountIf(Range("A2:A10"), myRange) > 1 Then
If 同一flag = False Then 同一flag = True
If InStr(1, MsgStr, myRange) = 0 Then
MsgStr = MsgStr & myRange & vbCrLf
End If
End If
Next
If 同一flag = True Then
MsgBox "同姓同名あり" & Chr(13) & _
"確認してください" & Chr(13) & _
vbCrLf & MsgStr
Else
End If
End Sub
