VBA教えて下さい

質問

VBA初心者です。
思った結果が出ず手詰まりしました。

こういった場合のコードを教えて欲しいです。
まず、例として
エクセルファイル名が
試験1(sheet1)
試験2とします(sheet2)

試験1のsheet1の中にある
B1～B100セルの文字をコピーするが
セルの背景色が塗られているセルはコピーしない
(セルの背景色塗りつぶしなしだけコピーするといった内容です)

そして、試験2のsheet2のB1～B100に貼り付けるが空白行は上に詰めるようにする

回答お願いします。

回答No.1

imogasi · ベストアンサー

（A）VBAで
試験１ブックのSheet1のA1セルを指し示す（値を取る）方法＝コード
試験２ブックのSheet２のA1セルを指し示す（値を取る、代入する）方法=コード
を勉強すること。
Ｇｏｏｇｌｅで「エクセル　ＶＢＡ　他ブックのセルを参照」などで調べること。
（B）そして（１）セルの値と（２）セルの書式（背景色塗りつぶしなど）は別であること。セルにはいろいろな属性があることを意識しているか。
したがって、それらの内容を捉えるコードはどうなるか勉強をすること。
（例）あるセルをコピーする。
そして貼り付け先の別のセルをポイントして
CTRL+ALT＋Vを押すと、出てくるウインドウで
数式、値、書式、コメント、入力規則、すべて、などが見えるが
コピーは「すべて」を移す、にあたる。
（３）仕事関係では、セルのコピーではなく、値を代入すれば済むことが多い。
初心者はそれをコピーと捉えているが、区別できているか。こちらをお勧めする。
コードでは、セル.Value＝セル.Valueのような式になる。
（４）＞「背景色塗りつぶしなしだけ」
はセル単位に判別が必要だからセルごとの繰り返しのコード記法をまず勉強するべきだ。
泥臭くはあるが、セルごとの繰り返しの方法で、シートのデータ処理は９割がた片付く。
初心者の間はこれ以上をとりあえず望むな。
質問者は自分の、今、目の前の、必要とする、１片の問題だけをその都度質問コーナーに丸投げしたいように見えるが、もっとエクセルやＶＢＡの基礎的なことを、本や、ＶＢＡの教室、ＷＥＢの記事で勉強すべきだ。
＞セルの背景色塗りつぶしなしだけコピーするといった内容です
はＧｏｏｇｌｅで、「エクセル　ＶＢＡ　塗りつぶしなし」で照会すれば。、コード・答えがわかる。
今どきエクセルＶＢＡの問題でＧｏｏｇｌｅでヒントが得られない問題は極少ない。
例としてＡ２セルにセル色の設定をしておいて
Sub test01()
For i = 1 To 4 'A1:A4について
If Cells(i, "A").Interior.ColorIndex <> 0 Then
MsgBox Cells(i, "A").Interior.ColorIndex
End If
Next i
End Sub
が応用できるかやってみること。
ーー
言いたいこと
・代入法の重視
・セルごと繰り返し処理の重視
・グーグルのＶＢＡ記事の活用
・エクセル全般の仕組み、成り立ちの初歩的部分理解
・他ブックにデータを分けないこと、他シートで済ませたい。

お礼

回答ありがとうございます

VBAに関わることを細かく教えてくれて
さらに勉強方法教えてくれてありがとうございます

回答を内容にて試し
勉強していきますm(__)m

回答No.2

kagakusuki

Sub QNo9267756_VBA教えて下さい()

Const CopyBookName As String = "試験1" 'コービー元のWorkBookのBook名
'Const CopySheetName As String = "Sheet1" 'コービー元のシートのシート名
Const CopyRangeAddress As String = "B1:B100" 'コービー元のセル範囲のアドレス
Const PasteBookName As String = "試験2" '貼り付け先のWorkBookのBook名
Const PasteSheetName As String = "Sheet2" '貼り付け先のシートのシート名
Const PasteCellAddress As String = "B1" '貼り付け先のセルのアドレス
Dim buf As Variant, i As Long, c As Range, CopyRange As Range _
, CopyBook As Workbook, PasteBook As Workbook _
, CopySheet As Worksheet, PasteSheet As Worksheet

For i = 0 To 1
buf = ""
On Error Resume Next
buf = Workbooks(Array(CopyBookName, PasteBookName)(i)).Name
On Error GoTo 0
If buf = "" Then
MsgBox Array("コピー元", "貼り付け先")(i) _
& "のワークブックとして設定されている" & vbCrLf & vbCrLf _
& Array(CopyBookName, PasteBookName)(i) & vbCrLf & vbCrLf & _
"というブック名のワークブックが開かれていません。" & vbCrLf _
& "マクロを終了しますので、上記のワークブックを開いてから" _
& "このマクロを再度起動して下さい。" _
, vbExclamation, "存在しないワークブック"
Exit Sub
End If
Next i
Set CopyBook = Workbooks(CopyBookName)
Set PasteBook = Workbooks(PasteBookName)
If IsError(Evaluate("ROW('[" & CopyBook.Name & "]" & CopySheetName & "'!A1)")) Then
MsgBox "コピー元のシートとして設定されている" _
& vbCrLf & vbCrLf & CopySheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set CopySheet = CopyBook.Sheets(CopySheetName)

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

If IsError(Evaluate("ROW('[" & PasteBook.Name & "]" & PasteSheetName & "'!A1)")) Then
With PasteBook
Set PasteSheet = .Sheets.Add(after:=.Sheets(.Sheets.Count))
End With
PasteSheet.Name = PasteSheetName
Else
Set PasteSheet = PasteBook.Sheets(PasteSheetName)
End If

With CopySheet.Range(CopyRangeAddress)
Set CopyRange = .Offset(.Rows.Count, .Columns.Count).Resize(1, 1)
For Each c In .Offset(0)
If c <> "" And c.Interior.Pattern = xlNone Then _
Set CopyRange = Union(CopyRange, c)
Next c
Set CopyRange = Intersect(CopyRange, .Offset(0))
End With
If CopyRange Is Nothing Then
MsgBox "コピーの対象となる条件に合致するセルがありません。" _
& vbCrLf & "マクロを終了します。" _
, vbExclamation, "該当セルなし"
Else
With PasteBook.Sheets(PasteSheetName).Range(PasteCellAddress)
.Resize(Range(CopyRangeAddress).Rows.Count, 1).ClearContents
CopyRange.Copy
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
End With

With Application
.CutCopyMode = False
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If

End Sub

お礼

いつもありがとうございますm(__)m

ベストアンサーは一番回答が早かった人にしました
すみませんm(__)m
コード試してみます(*^o^*)