こういうことがやりたいです。
１、新規ブック作成 ２、1997フォルダー内の19970303日報1を開きA1:K38をコピーし新ブック（sheet1）A1に貼り付け、次に19970303日報2を開きB3:K36をコピーし新ブック（sheet1）L5に貼り付ける。名前をつけて保存（新ブックのK2をファイル名にする）。すべて閉じる。また1からはじめ、同じ作業を次のファイル19970304日報1、19970304日報2に対して行う。
日報ファイルはファイル名が日付になっているため順番に並んでいます。またシートは１つです。
前にこのサイトで教えていた大ことを参考に作ってみましたが、日報ファイルが開いてコピーまでは動いていますが、貼り付けができないです。また名前をつけて保存もできないです。
初心者のため完全に理解して作っていなくておはづかしいですがご教授よろしくお願いします。
Sub copybook7()
Dim myPath As String 'このブックのパス
Dim DataFile As String 'Dir()で開くブック名
Dim copybook As Workbook '開いたブック
Dim DataSht As Worksheet 'このブックの貼り付けシート
Dim i As Long '貼り付け行カウンタ
Workbooks.Add
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
With ActiveSheet.PageSetup
Range("A1:G1,L1:AG1").ColumnWidth = 9
Range("H1:K1,AH1").ColumnWidth = 12
End With
With ThisWorkbook
Set DataSht = .Worksheets(1)
myPath = "C:\1997\"
DataFile = Dir(myPath & "*.xls", vbNormal)
i = 1
Do While DataFile <> ""
If DataFile <> .Name And _
InStr(1, DataFile, "日報") > 0 Then
Set copybook = Application.Workbooks.Open( _
Filename:=myPath & DataFile, ReadOnly:=True)
If InStr(1, DataFile, "日報1") > 0 Then
copybook.ActiveSheet.Range("A1:K38").Copy
DataSht.Range("A1").PasteSpecial Paste:=xlAll
ElseIf InStr(1, DataFile, "日報2") > 0 Then
copybook.ActiveSheet.Range("B3:K36").Copy
DataSht.Range("L5").PasteSpecial Paste:=xlAll
Else
End If
Application.DisplayAlerts = False
copybook.Close SaveChanges:=False
Application.DisplayAlerts = True
Set copybook = Nothing
End If
DataFile = Dir
ActiveWorkbook.SaveAs Filename:=ActiveSheet.Range("K2") & "日報"
.Close
Loop
Set DataSht = Nothing
End With
End Sub
エクセルマクロで困っています。
セルの範囲指定をしようとしています。
初心者過ぎて、よくわかりません。
現在のマクロ↓
Sub 済()
If ActiveCell.Column = 21 Then
Selection.FormatConditions.Delete '条件付き書式削除
With Selection.Interior
.ColorIndex = 16
.Pattern = xlSolid
End With
ActiveCell.Offset(0, 1).Select
With Selection.Interior
.ColorIndex = 16
.Pattern = xlSolid
End With
ActiveCell.Offset(0, 1).Select
With Selection.Interior
.ColorIndex = 16
.Pattern = xlSolid
End With
ActiveCell.Offset(0, 1).Select
With Selection.Interior
.ColorIndex = 16
.Pattern = xlSolid
End With
ActiveCell.Offset(0, 1).Select
With Selection.Interior
.ColorIndex = 16
.Pattern = xlSolid
End With
ActiveCell.Offset(0, 1).Select
With Selection.Interior
.ColorIndex = 16
.Pattern = xlSolid
End With
ActiveCell.Offset(0, 1).Select
With Selection.Interior
.ColorIndex = 16
.Pattern = xlSolid
End With
ActiveCell.Offset(0, 1).Select
With Selection.Interior
.ColorIndex = 16
.Pattern = xlSolid
End With
ActiveCell.Offset(0, 1).Select
With Selection.Interior
.ColorIndex = 16
.Pattern = xlSolid
End With
'色変え判定セル書き換え
ActiveCell.Offset(0, 5).Select
ActiveCell.FormulaR1C1 = "77"
ActiveCell.Offset(0, -5).Select
Else
answer = MsgBox("U列を選択して下さい", vbCritical)
End If
End Sub
やりたい事は、下記の通りです。
列Ｕがアクティブの時にＵ～ＡＣの行を塗りつぶし。
列は変動します。
今は、やり方がよく分からなかったため
オフセットで一つ一つ塗りつぶしてます。
マクロを組みすぎてファイルが重くなって困っています。
回答よろしくお願いいたします。
条件付き書式の色付けで「指定した文字を含む」という条件を
４つ以上つくるということで、下のマクロを探してきたんですが、少しでも意味を
知りたいです。
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
If Selection.Count > 1 Then Exit Sub
x = Target.Value
c = 0
If x Like "*あ*" Then c = 6
If x Like "*い*" Then c = 4
If x Like "*う*" Then c = 34
If x Like "*え*" Then c = 3
Target.Interior.ColorIndex = c
End Sub
これを実行したんですが、なぜ結合したセルの場合だけ、文字を
削除した際に色が残るのですか？
それを指示している部分と改善策を教えて下さい。
条件付き書式の色付けで「指定した文字を含む」という条件を
４つ以上つくるということで、下のマクロを探してきたんですが、少しでも意味を
知りたいです。
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
If Selection.Count > 1 Then Exit Sub
x = Target.Value
c = 0
If x Like "*あ*" Then c = 6
If x Like "*い*" Then c = 4
If x Like "*う*" Then c = 34
If x Like "*え*" Then c = 3
Target.Interior.ColorIndex = c
End Sub
これを実行したんですが、なぜ結合したセルの場合だけ、文字を
削除した際に色が残るのですか？
それを指示している部分と改善策を教えて下さい。
