- 締切済み
VBAでのデータ転記(再)
データがsheet1に縦記述で書いてあります。 C列 D列 ああ A01 いい A02 うう A03 . ささ B01 しし B02 すす B03 . はは AA01 ひひ AA02 ふふ AA03 . やや AB01 ゆゆ AB02 よよ AB03 . D列を元にしてC列の文字列をsheet2に以下のように並べたいです。D列はアドレス扱いででアルファベットが変わったら改行してデータを並べるようにします。 A列 B列 C列 ああ いい うう・ ささ しし すす・ ・・・・・ はは ひひ ふふ・ やや ゆゆ よよ・ 作成したコード Dim I As Integer, MAE As String, IMA As String, TEMP2 As String Dim X1 As Integer, Y1 As Integer, X3 As Integer, Y3 As Integer, PINNAME As String X1 = 4: Y1 = 2 X3 = 1: Y3 = 1 MAE = Sheets("Sheet1").Cells(Y1, X1) Do PINNAME = Sheets("Sheet1").Cells(Y1, X1 - 1) IMA = Sheets("Sheet1").Cells(Y1, X1) '今の値が入っている If IMA = "" Then Exit Do End If If Left(MAE, 1) <> Left(IMA, 1) Then Y3 = Y3 + 1: X3 = 1 Sheets("Sheet2").Cells(Y3, X3).Value = PINNAME X3 = X3 + 1 Else Sheets("Sheet2").Cells(Y3, X3).Value = PINNAME X3 = X3 + 1 End If MAE = Sheets("Sheet1").Cells(Y1, X1) Y1 = Y1 + 1 Loop Until IMA = "" Left関数でアドレスの左1文字を前後のセルで比較して異なる場合、改行する方法を考えましたが、AA01 AA02・・・がムリです。このコードに補足すればできるでしょうか?それとも別の考え方で行った方がいいでしょうか? 初心者レベルなので考え方も教えて下さい。宜しくお願いします。
- みんなの回答 (5)
- 専門家の回答
関連するQ&A
- ※VBA配列
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 ・・・教えてください
何度も質問させて頂いてます。すみません、 下記のプログラムはこの場で教えて頂いたプログラムで、 実行すると●の後を▲や■が追いかける動きをします。 下記のプログラムをある程度使用して 1~20の数字が順々で追いかけっこする プログラムを作成するにはどのようにすればいいのでしょうか… できればプログラムは長めにならず 20の数字から簡単に増やすことのできるような そんなプログラムが作成したいです… どなたかアドバイスお持ちの方 教えて下さいお願いします... 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)には10が入力されています。 宜しくお願い致します。
- ベストアンサー
- Excel(エクセル)
- エクセルVBAの転記処理について
2つのエクセルのブックがあり、 ブックAの[シート1]には、 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
- ベストアンサー
- その他(プログラミング・開発)
- エクセルVBAで。
お世話になります。 VBA初心者です。 (初心者でもないのですが、しばらく遠ざかっていました。) エクセルVBAの記述内容をコピーし、 エクセルの通常のシートへ貼り付けした際、 記述上「’」で始まる文字は緑色が付いていますが、 通常のシートへ貼り付けした際、黒字になってしまいます。 そこで、下記の様なVBAを記述し、貼り付け後に、 「’」から始まる文字を緑色に着色しようと試みましたが (やはり)うまくいきませんでした。 エクセル関数なんかも織り交ぜたおかしな記述だと思いますが 何となくやりたい事が伝わって頂けるかと思うのですが、 どう修正したら出来ますでしょうか。 ご教授下さいます様、宜しくお願いいたします。 記 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で行列を作る方法
次のようなプログラミングで1,0,-1の要素で作られる3×3行列を全通り調べています。 この場合3の9乗通り調べることができます。 これを4×4や5×5行列など数を大きくして調べたいのですが、このプログラムを配列を使うなどして 簡単にできる方法を教えてください。 よろしくおねがいします。 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 '要素がすべて1 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
- ベストアンサー
- オフィス系ソフト
お礼
ありがとうございます。 今度やってみます。