- 締切済み
VBAでのデータ転記（再）
Wendy02の回答
- Wendy02
- ベストアンサー率57% (3570/6232)
aki4720 さま 質問はともかく、この投稿の時点では、以下の問題のこちらのコメントもつけず、そのままにして、同様の質問を出すのは、マナーとしていかがなものかなって思います。ロジックとしては変わらないのですから、以下の私のコードを読み解けば、可能です。 http://oshiete1.goo.ne.jp/kotaeru.php3?q=1613040 比較する対象列 With Range("A1", Range("A1").End(xlDown)) ↓ D列にする。 Range(.Cells(r1, myCol), .Cells(r2, myCol)).Copy ↓ C列だから、Offset(,-1) で済むと思います。 もし、マクロの勉強の一つなら、あまり掲示板に安易に聞く方法よりも、自分で、Visual Basic Editor のデバッギングツールを使いながら、完成させたほうがよいです。 デバッギング・ツールを十分に使いこなせるようになると、自分の技術も向上していきます。 ただ、概ね、うまく出来ない時は、自分の技術が未熟なのであって、手がけたものはあっさり捨てたほうがよいです。他人のコードを参考にしながら、そのコードを借用していき、それで上達します。今回のものは、マクロ初心者というレベルで出来るかどうかは、私には分りません。
関連するQ&A
- ※ＶＢＡ配列
http://oshiete1.goo.ne.jp/qa5196795.htmlで 質問させてもらった者です。質問不足だったため 質問の内容を追加したかったのですが、追加の方法がわからず またこちらで質問させていただきました Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim X1 As Integer, Y1 As Integer Dim X2 As Integer, Y2 As Integer Dim maru As String, yoko As String, tate As String Dim sankaku As String, shikaku As String Sub 描画() Cells(Y2, X2).Value = shikaku Cells(Y1, X1).Value = sankaku Cells(Y, X).Value = maru End Sub Sub 削除() Cells(Y2, X2).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() X2 = X1 Y2 = Y1 X1 = X Y1 = Y If yoko = "右" Then X = X + 1 Else X = X - 1 End If If X = 30 Then yoko = "左" ElseIf X = 1 Then yoko = "右" End If If tate = "上" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 20 Then tate = "下" ElseIf Y = 1 Then tate = "上" End If End Sub Sub main() maru = "●" sankaku = "▲" shikaku = "■" X = 1 Y = 1 X1 = 1 Y1 = 1 X2 = 1 Y2 = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub a～tの文字が、上記のような動きをする プログラムを作成するにはどのように配列を活かせばいいですか? 配列がよくわかっておらず勉強したのですが…使えずにいます；;
- ベストアンサー
- その他（プログラミング・開発）
- Excel VBA ・・・教えてください
何度も質問させて頂いてます。すみません、 下記のプログラムはこの場で教えて頂いたプログラムで、 実行すると●の後を▲や■が追いかける動きをします。 下記のプログラムをある程度使用して １～２０の数字が順々で追いかけっこする プログラムを作成するにはどのようにすればいいのでしょうか… できればプログラムは長めにならず ２０の数字から簡単に増やすことのできるような そんなプログラムが作成したいです… どなたかアドバイスお持ちの方 教えて下さいお願いします... Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim X1 As Integer, Y1 As Integer Dim X2 As Integer, Y2 As Integer Dim maru As String, yoko As String, tate As String Dim sankaku As String, shikaku As String Sub 描画() Cells(Y2, X2).Value = shikaku Cells(Y1, X1).Value = sankaku Cells(Y, X).Value = maru End Sub Sub 削除() Cells(Y2, X2).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() X2 = X1 Y2 = Y1 X1 = X Y1 = Y If yoko = "右" Then X = X + 1 Else X = X - 1 End If If X = 30 Then yoko = "左" ElseIf X = 1 Then yoko = "右" End If If tate = "上" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 20 Then tate = "下" ElseIf Y = 1 Then tate = "上" End If End Sub Sub main() maru = "●" sankaku = "▲" shikaku = "■" X = 1 Y = 1 X1 = 1 Y1 = 1 X2 = 1 Y2 = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub
- ベストアンサー
- その他（プログラミング・開発）
- VBAについて質問します。
UserFormにTextBoxを縦13個×横9個＝117個で並べています。 ExcelのSheetに入力された内容をUserForm内のTextBoxに表示しています。 以下の様に・・・ Dim y As Integer Dim x As Integer For y = 1 To 13 For x = 1 To 9 Controls("TextBox" & (y - 1) * 9 + x) = ThisWorkbook.Sheets(2).Cells(y, x) Next x Next y このコードに表示された数字の先頭に￥を付けたいのですが、どの様にしたら良いでしょうか？ だだしUserForm上のTextBoxで縦13個×横9個のうち、縦1列目と縦3列目と縦5列目のみ￥は必要ないです。 それ以外を全て￥を数字の頭に付けたいのですが、よろしくお願いします。
- ベストアンサー
- Visual Basic
- VBA Evaluate関数 型が一致しません
Excel2003 VBAのEvaluateで以下の数式を実行すると エラー「型が一致しません」となってしまいます。 類似の質問を検索していろいろ参考にしてみたのですが 解決できなかったので質問させてください。 Sub test() Dim aa, bb, cc As String Dim y As Byte y = 1 With Sheets("Sheet1") aa = ".Cells(y, 1) > 0" bb = Left(aa, InStr(aa, "y") - 1) cc = Mid(aa, InStr(aa, "y") + 1) If Evaluate(bb & y & cc) Then ←ここでエラーになります。 y = 2 End If End With End Sub .Cells(1, 1)には１０が入力されています。 宜しくお願い致します。
- ベストアンサー
- Excel（エクセル）
- エクセルVBAの転記処理について
２つのエクセルのブックがあり、 ブックAの[シート１]には、 A列 B列 C列 D列 E列 コード 社名 品名 注文 合計 12345 グルメ社 カレー 400 800 78910 AA社 豆 100 250 12345 グルメ社 カレー 400 800 44123 ラック社 にんじん 350 400 のように、過去の注文データが1万件近くならんでおります。 ブックBの[現在]シートには、同じ列に同じ項目が並んでいるのですが、 A列 B列 C列 D列 E列 コード 社名 品名 注文 合計 12345 グルメ社 カレー 400 800 89123 100 250 55158 800 44123 ラック社 にんじん 350 400 のように、コード以外空欄というセルがあり、それが4千件あります。 ブックBにてB列が空欄の場合、ブックAのB・C・D列の値を転記する方法がわからず 困っております。 Sub ああ() Dim lRow As Long Dim i As Long Dim エラーコード(25000) Workbooks.Open Filename:=("C:\Documents and Settings\PC01\デスクトップ\bookA.xls") Workbooks("C:\Documents and Settings\PC01\デスクトップ\bookA").Activate Sheets("sheet1").Select lRow = Cells(Rows.Count, 4).End(xlUp).Row x = "" cnt = 0 For i = 4 To lRow Workbooks("C:\Documents and Settings\PC01\デスクトップ\bookA").Activate Sheets("sheet1").Select If Cells(i, 2).Value = "" Then JAN = Cells(i, 1) Windows("book2.xls").Activate Sheets("現在").Select 商品datarec = Cells(Rows.Count, 1).End(xlUp).Row x = "" Set 範囲 = Range(Cells(2, 1), Cells(商品datarec, 1)) 検索 = JAN On Error Resume Next x = Application.WorksheetFunction.match(検索, 範囲, 0) On Error GoTo 0 If x = "" Then cnt = cnt + 1 エラーコード(cnt) = JAN Else Windows("book2.xls").Activate Sheets("現在").Select メーカー名 = Cells(x + 1, 5).Value 品名 = Cells(x + 1, 6).Value Workbooks("C:\Documents and Settings\PC01\デスクトップ\bookA").Activate Sheets("sheet1").Select Cells(i, 2) = 社名 Cells(i, 3) = 品名 End If End If Next i If cnt <> 0 Then MsgBox "リストにない商品が" + Str(cnt) + "件ありました。" + vbCrLf End If End Sub というプログラムを組みました。宣言は強制させておりません。 途中で混乱してきたためおかしなコードになっております。 すみませんが、お願い致します。
- ベストアンサー
- その他（プログラミング・開発）
- エクセルでのシート間のデータの移動について
前回の質問ではこのような回答をしてもらいました。 ------------------------- Sub test() 'TXTファイル読み込みダイアログボックス Dim FileToOpen As String FileToOpen = Application.GetOpenFilename("テキストファイル (*.txt), *.txt") Dim myVal As String Dim x As Integer Dim y As Integer y = 1 '1列目から Open FileToOpen For Input As #1 ' シーケンシャル入力モードで開きます。 Do While Not EOF(1) ' ファイルの終端までループを繰り返します。 x = x + 1 Input #1, myVal Cells(x, y) = myVal If x Mod 20 = 0 Then'20行置きに y = y + 1 '列をずらす x = 1 '行をクリア End If Loop Close #1 ' ファイルを閉じます。 End Sub ------------------------- 今度はこのマクロを利用して同じファイル内のシートAAAにA1からA100までそれがC列まであるとします。 このデータをシートBBBに20行ずつ移したいのです。 わかる方がいましたら教えてください。 よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- ▲ExcelのVBA▼困っています
何度もVBAで質問させてもらい助けてもらっています。 懲りずにまた質問ですが… 下のプログラムは"●"が跳ね返るものなのですが… ●の後を■と▲が追うようなプログラムにするには なにを追加すればいいのでしょうか…？; どなたか教えて下さい;;お願いします;; Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim maru As String, yoko As String, tate As String Sub 描画() Cells(X, Y).Value = maru End Sub Sub 削除() Cells(X, Y).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() If yoko = "右" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 30 Then yoko = "左" ElseIf Y = 1 Then yoko = "右" End If If tate = "上" Then X = X + 1 Else X = X - 1 End If If X = 20 Then tate = "下" ElseIf X = 1 Then tate = "上" End If End Sub Sub main() maru = "●" X = 1 Y = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub
- ベストアンサー
- その他（プログラミング・開発）
- エクセルＶＢＡで。
お世話になります。 ＶＢＡ初心者です。 （初心者でもないのですが、しばらく遠ざかっていました。） エクセルＶＢＡの記述内容をコピーし、 エクセルの通常のシートへ貼り付けした際、 記述上「’」で始まる文字は緑色が付いていますが、 通常のシートへ貼り付けした際、黒字になってしまいます。 そこで、下記の様なＶＢＡを記述し、貼り付け後に、 「’」から始まる文字を緑色に着色しようと試みましたが （やはり）うまくいきませんでした。 エクセル関数なんかも織り交ぜたおかしな記述だと思いますが 何となくやりたい事が伝わって頂けるかと思うのですが、 どう修正したら出来ますでしょうか。 ご教授下さいます様、宜しくお願いいたします。 記 Sub 色() Dim y As Integer Dim x As Integer Dim a As Integer mysheet = ActiveSheet.Name For y = 1 To 10 x = Sheets(mysheet).Cells(Rows.Count, y).End(xlUp).Row a = 0 Do Until a > x a = a + 1 If Right(Cells(y, a), 1) = "'" Then Cells(y, a).Select Selection.Font.ColorIndex = 10 End If Loop Next End Sub
- ベストアンサー
- Visual Basic
- エクセル 転記ループが上手くいきません
ToDoファイルに記載した内容を別ファイルの管理シートに転記したいと考えています。 ToDoの4列目、管理シートの1列目に共通の管理IDを持たせてそこで紐づけさせ、ToDoの11列目に記載した内容を管理シートの72列目、ToDoの22列目に記載した内容を管理シートの73列目・・・といういう形で転記していきたいです。 以下のように作ってみたのですが、これでは転記されず、ここにもう一つループを加えると転記されるようになります。 （今は For i = 1 To last1 と For ii = 1 To last2の二つのループですが、もう一つ For j = 1 To last2 とかを加えると転記されます。） なぜなのか分かりません。 どなかた理由と解決方法を教えていただけないでしょうか？ どうぞよろしくお願いいたします。 Sub 管理シートへ貼り付け() Dim BookA As Workbook Dim BookB As Workbook Dim last1 As Long Dim last2 As Long Dim i As Long Dim ii As Long Workbooks.Open Filename:="管理シート.xlsm" Windows("ToDo.xlsm").Activate Set BookA = Workbooks("ToDo.xlsm") Set BookB = Workbooks("管理シート.xlsm") last1 = BookA.Sheets("ToDo").Cells(Rows.Count, 1).End(xlUp).Row last2 = BookB.Sheets("管理シート").Cells(Rows.Count, 1).End(xlUp).Row With BookA.Sheets("ToDo") For i = 1 To last1 For ii = 1 To last2 If .Cells(i, 4) = BookB.Sheets("管理シート").Cells(ii, 1) Then BookB.Sheets("管理シート").Cells(ii, 72) = .Cells(i, 11) BookB.Sheets("管理シート").Cells(ii, 73) = .Cells(i, 22) BookB.Sheets("管理シート").Cells(ii, 74) = .Cells(i, 23) BookB.Sheets("管理シート").Cells(ii, 75) = .Cells(i, 24) BookB.Sheets("管理シート").Cells(ii, 76) = .Cells(i, 25) End If If .Cells(i, 1).Value = "貼付け後削除" Then Rows(i).Hidden = True End If Exit For Next Next End With MsgBox "転記が終わりました" End Sub
- 締切済み
- Excel（エクセル）
- VBAで行列を作る方法
次のようなプログラミングで１，０，－１の要素で作られる3×3行列を全通り調べています。 この場合３の９乗通り調べることができます。 これを4×4や５×５行列など数を大きくして調べたいのですが、このプログラムを配列を使うなどして 簡単にできる方法を教えてください。 よろしくおねがいします。 Sub test() Dim a As Integer '行 Dim b As Integer '列 Dim c As Integer, i As Integer, j As Integer, d As Integer, e As Integer Dim 内積 As Integer, step As Integer Dim f As Integer, g As Integer, h As Integer, l As Integer, m As Integer, n As Integer, k As Integer, x As Integer Dim sum As Integer, total As Integer Dim aa As Integer, aaa As Integer, aaaa As Integer, bb As Integer, bbb As Integer, bbbb As Integer a = 3 '行 b = 3 '列 c = 0 内積 = 0 con = 0 sum = 0 tatal = 0 aa = 0 aaa = 0 aaaa = 0 bb = 0 bbb = 0 bbbb = 0 x = 0 For n = 0 To 2 For m = 0 To 2 For l = 0 To 2 For k = 0 To 2 For h = 0 To 2 For g = 0 To 2 For f = 0 To 2 For e = 0 To 2 For d = 0 To 2 '要素がすべて１ For i = 1 To a For j = 1 To b Cells(i, j) = 1 Next j Next i If bbbb = 1 Then Cells(a - 2, b - 2) = 0 ElseIf bbbb = 2 Then Cells(a - 2, b - 2) = -1 End If If bbb = 1 Then Cells(a - 1, b - 2) = 0 ElseIf bbb = 2 Then Cells(a - 1, b - 2) = -1 End If If bb = 1 Then Cells(a, b - 2) = 0 ElseIf bb = 2 Then Cells(a, b - 2) = -1 End If If aaaa = 1 Then Cells(a - 2, b - 1) = 0 ElseIf aaaa = 2 Then Cells(a - 2, b - 1) = -1 End If If aaa = 1 Then Cells(a - 1, b - 1) = 0 ElseIf aaa = 2 Then Cells(a - 1, b - 1) = -1 End If If aa = 1 Then Cells(a, b - 1) = 0 ElseIf aa = 2 Then Cells(a, b - 1) = -1 End If If total = 1 Then Cells(a - 2, b) = 0 ElseIf total = 2 Then Cells(a - 2, b) = -1 End If If sum = 1 Then Cells(a - 1, b) = 0 ElseIf sum = 2 Then Cells(a - 1, b) = -1 End If If con = 1 Then Cells(a, b) = 0 ElseIf con = 2 Then Cells(a, b) = -1 End If con = con + 1 Next d con = 0 sum = sum + 1 Next e sum = 0 total = total + 1 Next f total = 0 aa = aa + 1 Next g aa= 0 aaa = aaa + 1 Next h aaa = 0 aaaa = aaaa + 1 Next k aaaa = 0 bb = bb + 1 Next l bb = 0 bbb = bbb + 1 Next m bbb = 0 bbbb = bbbb + 1 Next n End Sub
- ベストアンサー
- オフィス系ソフト
お礼
どうもありがとうございました。 初めての利用でしたのでよくわからず、マナーの件については失礼しました。自分がかなり未熟なこともわかり、解読中でまだ時間がかかりそうなのでお礼を先に伝えます。