皆様 よろしくお願いします。
エクセルで社内で使っている現金出納帳がありまして。
D6セルから下方向に数字・日本語アルファベット混在して
入力されています。
例「1月13日 現金売上」 「2月13 切手代」 「3月31日 食事料金」
といった具合です。
そのセルの内容を判断して
G6セルから下方向に
該当する数字を書きこむべく
以下のようなマクロを作っています。
条件はもっと増えてきた場合に
一個一個条件を書き足すと膨大なマクロになってくると思いまして
スマートな書き方がございましたら
ご指導くださると助かります。
Sub 科目自動入力()
Dim a As Integer
a = 6
'内容が空白になるまで繰り返す
Do Until Cells(a, 4).Value = ""
'「売上」が含まれていたら700
If Cells(a, 4).Value Like "*売上*" Then Cells(a, 7).Value = 700
'「切手」もしくは「レター」が含まれていたら756
If Cells(a, 4).Value Like "*切手*" Or Cells(a, 4).Value Like "*レター*" Then Cells(a, 7).Value = 756
'「残業」もしくは「食事」が含まれていたら746
If Cells(a, 4).Value Like "*残業*" Or Cells(a, 4).Value Like "*食事*" Then Cells(a, 7).Value = 746
'「旅費」もしくは「交通費」が含まれていたら755
If Cells(a, 4).Value Like "*旅費*" Or Cells(a, 4).Value Like "*交通費*" Then Cells(a, 7).Value = 755
a = a + 1
Loop
End Sub
いつもお世話になります。
excel２０１０を使っておりますが、下記で原因不明のエラーで困っています。
やりたい事はオートフィルターで抽出された行のみ削除（１列目はタイトルの為
削除対象外）
If .SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
ネットで調べまして上記で良いと思うのですが、下記のエラーが出てしまいます。
実行時エラー＝438
オブジェクトは、このプロパティまたはメソッドをサポートしていません。
ユーザーフォームから実行しているのが原因ですかね？？
宜しくお願い致します。
お世話になります。
果物の出荷先を県別にまとめたシートがあります。それを県別に分割して、県ごとに新しいブックにコピーしたいと思っています。
Dim w As Worksheet
Dim n As Long
Dim r As Long
Dim s As String
Dim WSH As Variant
Dim myPath As String
Set w = ActiveSheet
n = Worksheets.Count
On Error GoTo errhandle
For r = 8 To w.Range("A65536").End(xlUp).Row
s = w.Cells(r, "B") & "_" & w.Cells(r, "C")
w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1)
Next r
On Error GoTo 0
Set WSH = CreateObject("Wscript.Shell")
myPath = WSH.specialfolders("Desktop") & "\"
For r = Worksheets.Count To n + 1 Step -1
Worksheets(Worksheets.Count).Copy
ActiveSheet.Columns.AutoFit
ActiveWorkbook.SaveAs Filename:=myPath & ActiveSheet.Name
ActiveWorkbook.Close False
Application.DisplayAlerts = False
Worksheets(Worksheets.Count).Delete
Application.DisplayAlerts = True
Next r
w.Select
Exit Sub
errhandle:
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = s
w.Rows(1).Copy Range("A1")
Resume
End Sub
上記のマクロを実行した際に、解消したい点が2点あります。
1、項目(ヘッダー)としてコピーされる行が、現在1行目のみです。それを1～8行目にしたい。
2、ファイル名にセルを参照してコードと県名を繋げたものをつけているのですが、シート名もファイルと同じになってしまいます。シート名は元のファイルについているシート名を引き継ぎたいです(各県共通)
以上について、上記のコードのどの部分を変更すればよろしいでしょうか。
お分かりになられる方おられましたら、どうぞ教えてください。
よろしくお願い致します。
いつもお世話になります。
今回は下記コードを記載したのですが、どうにも遅いので何とかする方法があれば
との思いから投稿させて頂きます。
ListBox1（590以上の項目があります）をクリックしたら
非対象シートのA列を検索して、ヒットした場合
同シートのB列と同様の数字をListBox２から探し出して
チェックを付けて行く。（一応、計算ストップ等のコードは試しましたが変わりません）
基本情報としては
最初に、選択されているかもしれないListBox２のチェックをクリアをします。
ListBoxの１，２は同じ情報を使っています。
なので、ListBox１と同じ情報のListBox２については、最初の方でチェックを
付ける処理をしています。（(1)）
その後の処理が遅いのですが、ListBox１のどれかをクリックする度に２０秒以上
動きが止まってしまうので、何か対策があればどうぞ宜しくお願い致します。
※なぜか処理が終わるとフォームが消えてしまいます。例えばブラウザを一度アクティブ
にしてからエクセルに戻ると出てくるのですが、何が原因でしょうか？
Private Sub ListBox1_Click()
Dim RR, HRR As Range
Dim SID As Integer
'
'With Application
' .ScreenUpdating = False
' .EnableEvents = False
' .Calculation = xlCalculationManual
'End With
'// 選択されているかもしれないListBox２のチェックをクリア
For i = 0 To Me.ListBox2.ListCount - 1
ListBox2.Selected(i) = False
Next
Debug.Print Time; " - 同じ会社にチェックを付けるスタート"
'// 同じ会社にチェックを付ける
For si = 0 To ListBox2.ListCount - 1
If Me.ListBox2.List(si, 0) = RR Then
Me.ListBox2.Selected(si) = True
si = 0
Exit For
End If
Next
Debug.Print Time; " - 同じ会社にチェックを付ける終り"
Debug.Print Time; " - 非対象シートにある対象外にチェックを付ける スタート"
'// 非対象シートにある対象外にチェックを付ける
With Sheets("非対象")
For Each RR In .Range(.Cells(1, 1), .Cells(.Cells(600000, 1).End(xlDown).Row - 1, 1))
If RR = Me.ListBox1 Then
For si = 0 To ListBox2.ListCount - 1
If Me.ListBox2.List(si, 0) = .Cells(RR.Row, 2) Then
Me.ListBox2.Selected(si) = True
End If
Next
End If
Next
End With
Debug.Print Time; " - 非対象シートにある対象外にチェックを付ける 終り"
End Sub
