私の質問を拝読いただき、ありがとうございます。
マトリックス形式のデータがワークシートに埋め込まれています。
特定のフィールドに入っている各レコードのデータをエクセルで検査するマクロを作ろうとしています。
検査方法としては、一定量以上の文字列が入っているセルを特定の色で塗るというものです。
（条件付書式でも同じことが可能ですが、操作の関係上、マクロで実現したいものです。）
次のようなコードを実行すると、各セル内の文字量が80文字を超えていようがいまいが、
B列の全てのセルがcolor=7で塗りつぶされてしまいます。
------------------------------------
Private Sub 検査()
Dim objColumn As String
Dim objCell As Range
Dim mojiByt As Integer
i = 2
objColumn = Columns(i).Address
For Each objCell In Range(objColumn)
With objCell
mojiByt = LenB(.Value)
Select Case mojiByt
Case Is > 80
.Interior.Color = 7
Case Else
.Interior.Color = xlNone
End Select
End With
Next
End Sub
------------------------------------
このコードのエラーをご指摘いただきますと幸いです。
よろしくお願い致します。
こんばんは
VB2008で銀行ローンの計算式をつくりましたが、計算の結果は
多少ずれています。
計算式が間違っているか、引数の型の設定が間違っているかよくわかりらないですから、聞きたいです。
----------------------------------------------------
Private Sub Button41_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button41.Click
'a = 年利 b =月返済額 c = 年数 d = 総返済金額
Dim a As Single
Dim b As Single
Dim c As Integer
Dim d As Integer
Dim K As Double
'貯金の目標金額より、毎月に貯金必要な金額を算出
If RadioButton5.Checked = True Then
K = d / (c * 12)
Label24.Text = "毎月、 " & K & " 円を貯金する必要"
K = 0
End If
'毎月返済額と年数を固定して、総返済金額を算出
If RadioButton6.Checked = True Then
a = 5
a = (a * 0.01) / 12
K = (b + (b * a)) * (c * 12)
Label24.Text = c & "年間の総返済金額は " & K & " 万です。"
K = 0
End If
'総返済金額と年利を決定し、毎月に返済する金額を算出
If RadioButton7.Checked = True Then
a = 5
a = a * 0.01
K = (d + (d * a * c)) / (c * 12)
Label24.Text = "毎月 " & K & " 円の返済です。"
K = 0
End If
End Sub
--------------------------------------------------------------
上記の計算式では
例１：
年利=5%, 借入金額(総)=1000000円, 返済回数=12か月の場合、
結果は 毎月87500.0000620882(誤 ?)となっています。
別の購入したマクロ本でしたら、85607(正?)となっています。
例２：
年利=5%, 毎月返済額=1000000円, 返済回数=12か月の場合、
結果は 総返済金額 361500.000078231(誤 ?)となっています。
別の購入したマクロ本でしたら、350437(正?)となっています。
以上、よろしくお願いします。
マクロ初心者です。（エクセル２００３使用）
Sheet2の管理番号をSheet1の管理番号と照合し、同じであれば、数量など３項目を上書きするマクロを作ろうとしています。
（Sheet1：日々更新される元データ）全データ数約500件くらい
Ａ列 ,Ｂ, Ｃ, Ｄ, ・・・
１行 管理番号,品名,注文数量,出荷数量,・・・
（Sheet2：上書きさせたいシート）全データ数約80件くらい
Ｇ列 ,Ｈ, Ｉ Ｊ
９行 管理番号,品名,注文数量,出荷数量
↑シート２にある管理番号をもとに数量などを照合＆上書きをしたいのです。
■シート１も２も行数は日々変動します。
■シート１で、まれに同じ管理番号が２つ存在することがありますが、取り出したい数量などのデータは、常に１番目に照合する管理番号です。
Sub シート間照合と上書き()
Dim i As Integer
a = Worksheets("sheet1").Range("a65536").End(xlUp).Row
For i = 2 To a
If Worksheets("sheet1").Range("A2") = Worksheets("sheet2").Range("G9") Then
Worksheets("sheet1").Cells(1, i) = Worksheets("sheet2").Range("G9")
Worksheets("sheet1").Cells(2, i) = Worksheets("sheet2").Range("H9")
Worksheets("sheet1").Cells(3, i) = Worksheets("sheet2").Range("I9")
While Cells(1, i) <> ""
i = i + 1
Wend
End If
Next
End Sub
■上記 模索しながらマクロを作ってみたのですが、エラーにはならないのですが（F8）、まったく動きませんでした。
すみませんが、お力をかしてください。
よろしくお願いいたします。
ExcelのVBAでマクロを作成していますが、プログラムの壁にぶつかってしまいました。恐れ入りますが、ご回答をお願い致します。
具体的な作業：
３０程度のデータをリストボックスに表示させ、必要なデータを選択してもらうプログラムです（ここまではできています）。選択されたデータは作業者にカラーで確認できるようにしましたが、これらの抽出データをバックアップするために、行列を入れ替え「左から右へ詰めて」別シート（Sheet2)へ貼り付けるにはどうすればよいか、アドバイスをお願いします。
お恥ずかしながら、できているところまで掲載させていただきます。
Private Sub データ選択_Click()
Dim 数 As Integer
If lst一覧.ListIndex = -1 Then
MsgBox "分析するデータを選択してください"
lst一覧.SetFocus
Else
For 数 = 0 To lst一覧.ListCount - 1
If lst一覧.Selected(数) = True Then
Cells(20 + 数, 23).Resize(, 8).Interior.ColorIndex = 36
Cells(20 + 数, 23).Resize(, 8).Copy
Sheets("Sheet2").Select
Range("ここがわかりません").Select
Selection.PasteSpecial
Paste:=xlPasteFormulas,
Operation:=xlNone,
SkipBlanks:=True,
Transpose:=True
Sheets("Sheet1").Select
Range("A24").Select
End If
Next 数
End If
End Sub
ExcelのVBAでマクロを作成していますが、プログラムの壁にぶつかってしまいました。恐れ入りますが、ご回答をお願い致します。
具体的な作業：
３０程度のデータをリストボックスに表示させ、必要なデータを選択してもらうプログラムです（ここまではできています）。選択されたデータは作業者にカラーで確認できるようにしましたが、これらの抽出データをバックアップするために、行列を入れ替え「左から右へ詰めて」別シート（Sheet2)へ貼り付けるにはどうすればよいか、アドバイスをお願いします。
お恥ずかしながら、できているところまで掲載させていただきます。
Private Sub データ選択_Click()
Dim 数 As Integer
If lst一覧.ListIndex = -1 Then
MsgBox "分析するデータを選択してください"
lst一覧.SetFocus
Else
For 数 = 0 To lst一覧.ListCount - 1
If lst一覧.Selected(数) = True Then
Cells(20 + 数, 23).Resize(, 8).Interior.ColorIndex = 36
Cells(20 + 数, 23).Resize(, 8).Copy
Sheets("Sheet2").Select
Range("ここがわかりません").Select
Selection.PasteSpecial
Paste:=xlPasteFormulas,
Operation:=xlNone,
SkipBlanks:=True,
Transpose:=True
Sheets("Sheet1").Select
Range("A24").Select
End If
Next 数
End If
End Sub
以下のコードでアクセスからデータをエクスポート後に
複数（50くらい）シート名を変更し、シートを並び替えし、
列幅を整えています。
次にデータをソートしたいのですが、うまく範囲指定が
できないで２日くらいすぎてしまいました。
以下の**でかこった部分で定義ができません。
どなたかお助けしていただけないでしょうか？
よろしくお願いします。
うまく改行できないですいません・・。
****************************************************
h = 1
o = 29
ws.Columns(h & ":" & o).Select
範囲指定したいのはA列からAC列までのデータの入った
行数までです。
With ws.Range(.Cells(1), .Cells(ws.Columns.Count).End(xlToUP))
****************************************************
Private Sub CommandButton1_Click()
Dim path$, wb As Workbook, wbName$
Dim ws As Worksheet, i&
Dim intLoopA As Integer
Dim intLoopB As Integer
Dim h As Long
Dim o As Long
path = ThisWorkbook.path & "\"
wbName = Dir(path & "*.xls")
Do Until wbName = ""
If wbName <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(path & wbName)
i = 2
For Each ws In wb.Worksheets
If Trim(ws.Range("A2")) <> "" Then
On Error Resume Next
ws.Name = ws.Range("A2")
If Err.Number <> 0 Then
ws.Name = ws.Range("A2") & " (" & i & ")"
i = i + 1
End If
On Error GoTo 0
End If
For intLoopA = 1 To Sheets.Count
For intLoopB = 1 To Sheets.Count - 1
If Sheets(intLoopB).Name > Sheets(intLoopB + 1).Name Then
Sheets(intLoopB).Move after:=Sheets(intLoopB + 1)
End If
Next intLoopB
Next intLoopA
With ws.Rows(1)
With ws.Range(.Cells(1), .Cells(ws.Columns.Count).End(xlToLeft))
.Interior.ColorIndex = 15
.EntireColumn.AutoFit
End With
End With
h = 1
o = 29
ws.Columns(h & ":" & o).Select
With ws.Range(.Cells(1), .Cells(ws.Columns.Count).End(xlToUP))
.Sort _
Key1:=Range("G1"), Order1:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
End With
End With
DoEvents
Next
wb.Save
End If
wbName = Dir
Loop
Set wb = Nothing
Set ws = Nothing
MsgBox "処理が完了しました。", vbInformation, "処理確認"
End Sub
