ここから質問投稿すると、最大10000ポイント当たる!!!! >>

A列に数値データ、B列に文字データが入力されています。
これをコピーして形式を選択して貼り付けで行列を入れ替えて、1行目のA~J列に数値、K~T列に文字と10個単位でどんどん移動をかけます。
データ数は3000件以上ありできれば上記作業を自動化したいのですが・・・。
みなさんどうかお願い致します。

A 回答 (11件中1~10件)

すみません。


前のは10個目に空欄があっても一行空きませんでした。

Option Explicit

Sub irekae()
  Const halfretsu = 10
  
  Dim mototop As Integer
  Dim atotop As Integer
  Dim gyou As Integer
  Dim thislinec As Integer

  mototop = 1
  atotop = 1
  gyou = Range("A10000").End(xlUp).Row
  
  Do While mototop <= gyou
    thislinec = ido(mototop, atotop, halfretsu)
    
    If thislinec < 0 Then
      mototop = mototop + halfretsu
      atotop = atotop + 1
    Else
      mototop = mototop + thislinec
      atotop = atotop + 2
    End If
  Loop
  Columns("A:C").Select
  Selection.Delete Shift:=xlToLeft
End Sub

Private Function ido(mototop, atotop, halfretsu)
  Dim tempnum As Integer
  Dim stopnum As Integer
  Dim tempchar As String
  
  Const yobiake = 3
  
  Dim i As Integer
  
  stopnum = -1
  
  For i = 1 To halfretsu
    If Cells(mototop + i - 1, 2).Value = "" Then
      stopnum = i
      Exit For
    End If
    
    tempnum = Cells(mototop + i - 1, 1).Value
    Cells(mototop + i - 1, 1).Value = ""
    Cells(atotop, i + yobiake).Value = tempnum
    tempchar = Cells(mototop + i - 1, 2).Value
    Cells(mototop + i - 1, 2).Value = ""
    Cells(atotop, i + halfretsu + yobiake).Value = tempchar
  Next
  ido = stopnum
End Function
    • good
    • 0
この回答へのお礼

感動です。
正直無理なんだと思ってました。
ダミーで150件試しましたがきれいに並び変わりました。
本当にありがとうございました。

お礼日時:2003/05/20 00:43

すいませんなんか勘違いしていたようで


もし途中で空行があったらその行へのコピーをやめて一行あけてからコピーを再開する。
でいいんですね?

Option Explicit

Sub irekae()
  Const halfretsu = 10
  
  Dim mototop As Integer
  Dim atotop As Integer
  Dim gyou As Integer
  Dim thislinec As Integer

  mototop = 1
  atotop = 1
  gyou = Range("A10000").End(xlUp).Row
  
  Do While mototop <= gyou
    thislinec = ido(mototop, atotop, halfretsu)
    mototop = mototop + thislinec
    If thislinec >= halfretsu Then
      atotop = atotop + 1
    Else
      atotop = atotop + 2
    End If
  Loop
  Columns("A:C").Select
  Selection.Delete Shift:=xlToLeft
End Sub

Private Function ido(mototop, atotop, halfretsu)
  Dim tempnum As Integer
  Dim tempchar As String
  
  Const yobiake = 3
  
  Dim i As Integer
  
  For i = 1 To halfretsu
    If Cells(mototop + i - 1, 2).Value = "" Then
      Exit For
    End If
    
    tempnum = Cells(mototop + i - 1, 1).Value
    Cells(mototop + i - 1, 1).Value = ""
    Cells(atotop, i + yobiake).Value = tempnum
    tempchar = Cells(mototop + i - 1, 2).Value
    Cells(mototop + i - 1, 2).Value = ""
    Cells(atotop, i + halfretsu + yobiake).Value = tempchar
  Next
  ido = i
End Function
    • good
    • 0

No.2です。


前のは10行ずつ書入りした後の次のA列のトップ(例えばA41)に空欄があったらストップするように作ってあったのでたまたまそこに空欄があったら止まってしまうものでした。
とりあえず、元のデータが行数が1万行未満という想定で作り変えてみました。

Option Explicit

Sub irekae()
  Const halfretsu = 10
  
  Dim mototop As Integer
  Dim atotop As Integer
  Dim gyou As Integer
  Dim gyouA As Integer
  Dim gyouB As Integer

  mototop = 1
  atotop = 1
  gyouA = Range("A10000").End(xlUp).Row
  gyouB = Range("B10000").End(xlUp).Row
  If gyouA >= gyouB Then
    gyou = gyouA
  Else
    gyou = gyouB
  End If
  
  Do While mototop <= gyou
    Call ido(mototop, atotop, halfretsu)
    mototop = mototop + halfretsu
    atotop = atotop + 2
  Loop
  
End Sub

Private Sub ido(mototop, atotop, halfretsu)
  Dim tempnum As Integer
  Dim tempchar As String
  
  Dim i As Integer
  
  For i = 1 To halfretsu
    If Cells(mototop + i - 1, 1).Value <> "" Then
      tempnum = Cells(mototop + i - 1, 1).Value
      Cells(mototop + i - 1, 1).Value = ""
      Cells(atotop, i).Value = tempnum
    End If
    
    tempchar = Cells(mototop + i - 1, 2).Value
    Cells(mototop + i - 1, 2).Value = ""
    Cells(atotop, i + halfretsu).Value = tempchar
  Next
End Sub
    • good
    • 0
この回答へのお礼

ありがとうございます。
試してみたところなぜか一行おきに改行が入ってしまいますです・・・・

お礼日時:2003/05/18 00:20

No,#4-5です。


補足要求しますが、元軸計算はA列(数字)の方でよろしいのでしょうか?

例えばB列(文字)に空行(NULL)がある場合の扱いは同じくご質問にあるように空行扱いでOKなのか、
又は、あくまでA列が空行だった場合だけに空行処理をするのか、その辺が曖昧な感じがします。

*:A列が空行なら必ずB列も空行なのでしょうか?
*:移し替えが10未満でも途中に空行があったら強制的に行をあけるのでしょうか?

この回答への補足

A列が空行なら必ずB列も空行です。
移し替えが10未満でも途中空行があったら強制的に行を空けます。
1~50のデータで25行目と31行目が空行であれば
1 2 3 4 5 6 7 8 910
11121314151617181920
21222324

2627282930

32333435363738394041
424344454647484950

と並んで欲しいのです

補足日時:2003/05/17 23:36
    • good
    • 0

#6のものです。

#6の補足にお書きになっている要求は
、やって見たところ#3の回答のままで叶えられると思います。
A列、B列に空白のセルが散在・混在しておれば、そのまま所定の所へ空白セルを移します。
やってみてくださって、不都合な点があればお知らせ下さい。

この回答への補足

私の説明不足ですみません、補足致します。
所定のセル(行)が空白である場合そのまま移すのではなく空行を一つ作って欲しいのです。2行以上の空白(行)があればマクロを止めて欲しいのです。A列1~31、B列あ~、の場合で3行目と10行目に空行がある場合

12         あい
※3行目がないので空行
456789       うえおかきく
※10行目がないので空行
11121314151617181920けこさしすせそたちつ
21222324252627282930てとなにぬねのはひふ
31          へ

このような説明でわかりますでしょうか・・・

補足日時:2003/05/17 23:59
    • good
    • 0

#1,#3のものです。


実はデータは3000件ちょうどではなく、その時々で異なります。
なのでこのVBAだと都度件数を把握しなければならず
少し色々盛りこまないように遠慮してました。
簡単です。
d = Range("a1").CurrentRegion.Rows.Count
かまたは
d=Range("A65536").End(xlUp).Row を最初に入れる。
For i = 1 To 300 Step 10 をFor i = 1 To d Step 10
に変更するで解決します。

この回答への補足

元データの途中に空行がある場合、並べ替え後データも空行を作ることはできるでしょうか?
1      1234

3      567

   →



という感じで1行10個なくても改行になり、さらに1行空行を入れてまた続きが入る。
なんとかなりますでしょうか・・・

補足日時:2003/05/17 08:29
    • good
    • 0
この回答へのお礼

imogasiさんは朝早いんですね(^^)丁寧にありがとうございます。
試したところ無事うごきました、ありがとうございます。
そこで相談なのですが↑補足のような事もできるものでしょうか?

お礼日時:2003/05/17 08:28

No,#4です。


勘違いしておりました。スミマセンm(__)m
再調整版をUPします。
--------------------------------------------------
Sub Macro2()

Dim myLastLow As Long, i As Long, n As Long
Dim str As String, str2 As String
Dim str_rv As String, str_rv2 As String, str_rv3 As String, str_rv6 As String

n = 1
n2 = 1

myLastLow = Range("A65536").End(xlUp).Row
Cells(1, 1).Select

MsgBox "myLastLow = " & myLastLow

For i = 1 To myLastLow Step 10

str_rv = i
str_rv2 = i + 9
str_rv3 = n
str_rv6 = n

str = "A" + str_rv + ":A" + str_rv2
Range(str).Select
Application.CutCopyMode = False
Selection.Copy
Range("C" + str_rv3).Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True

str2 = "B" + str_rv + ":B" + str_rv2
Range(str2).Select
Application.CutCopyMode = False
Selection.Copy
Range("M" + str_rv6).Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
n = n + 1
Next i

MsgBox "A&B列を削除します。"
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select

End Sub

この回答への補足

※お礼文の100文字制限でお礼が切れてしまいました、すみません。

回答ありがとうございます!うまく動いたのですが↓のような事はできるものでしょうか?

補足日時:2003/05/17 08:21
    • good
    • 0
この回答へのお礼

そこでちょっと相談なのですが、下の方にも着込みしたのですが、元データの途中に空行がある場合、並べ替え後データも空行を作ることはできるでしょうか?

1      1234

3      567

   →




という感じで1行10個なくても改行になり、さらに1行空行を入れてまた続きが入る。

なんとかなりますでしょうか・・・

お礼日時:2003/05/17 02:37

お望みの処理はこんな感じでしょうか?


汎用的な可変タイプのマクロを組んでみました。
バックアップを作成してから下記のマクロを試してみて下さい。
--------------------------------------------------
Sub Macro()

Dim myLastLow As Long, i As Long, n As Long
Dim str As String, str2 As String
Dim str_rv As String, str_rv2 As String, str_rv3 As String, str_rv6 As String

n = 1
n2 = 1

myLastLow = Range("A65536").End(xlUp).Row
Cells(1, 1).Select
MsgBox "myLastLow = " & myLastLow

For i = 1 To myLastLow Step 10

str_rv = i
str_rv2 = i + 9
str_rv3 = n
str_rv6 = n + 1

str = "A" + str_rv + ":A" + str_rv2
Range(str).Select
Application.CutCopyMode = False
Selection.Copy
Range("C" + str_rv3).Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True

str2 = "B" + str_rv + ":B" + str_rv2
Range(str2).Select
Application.CutCopyMode = False
Selection.Copy
Range("C" + str_rv6).Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
n = n + 2
Next i

MsgBox "A&B列を削除します。"
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select

End Sub
    • good
    • 0

テストデータとして


A1に1、A2に2を入れ、A1:A2を範囲指定して
+ハンドルを出し引っ張る。1-数百の連続数を入力する。
B1に501、B2に502を入れ、B1:B2を範囲指定して+ハンドルを出し下へ引っ張る。501-連続数を
セルにセットする。
Sub test02()
j = 1
'For i = 1 To 3000 Step 10
For i = 1 To 300 Step 10
Worksheets("Sheet1").Select
Worksheets("Sheet1").Range(Cells(i, "A"), Cells(i + 9, "A")).Copy
Worksheets("Sheet2").Select
Cells(j, "A").Select
Selection.PasteSpecial Paste:=xlAll, Transpose:=True
'-------
Worksheets("Sheet1").Select
Worksheets("Sheet1").Range(Cells(i, "B"), Cells(i + 9, "B")).Copy
Worksheets("Sheet2").Select
Cells(j, "K").Select
Selection.PasteSpecial Paste:=xlAll, Transpose:=True
j = j + 1
Next i
End Sub
を標準モジュール画面にコピーし、実行する。
結果はSheet2にA1:TXXXに
1、2、3・・10,501,502、・・510
11,12、13・・511、512,513、・・520
21,22,23、・・521,522、・・530
・・・
となります。
「標準モジュール画面にコピーし、実行する」方法がわからなければ補足します。
’の付いた行は3000行を処理するときのためです。
’を省けば3000行用になります。その時は
For i = 1 To 300 Step 10の行を抹消します。
    • good
    • 0
この回答へのお礼

回答ありがとうございます。
実はデータは3000件ちょうどではなく、その時々で異なります。
なのでこのVBAだと都度件数を把握しなければならず少々不便な感じがしました。(勝手いってすみません)

お礼日時:2003/05/17 02:34

多分こういうのはマクロを使わないと無理だと思います。


念のため「形式を選択して貼り付け」は「値」だけを選ぶんですよね?

ツール(T)→マクロ(M)→Visual Basic Editor(V)
または
Alt+F11

Visual Basic Editorを起動する。
挿入(I)→標準モジュール(M)
として
右側に出来たウィンドウに

Sub irekae()
  Const halfretsu = 10
  
  Dim mototop As Integer
  Dim atotop As Integer

  mototop = 1
  atotop = 1
  
  Do While Cells(mototop, 1).Value <> ""
    Call ido(mototop, atotop, halfretsu)
    mototop = mototop + halfretsu
    atotop = atotop + 1
  Loop
  
End Sub

Private Sub ido(mototop, atotop, halfretsu)
  Dim tempnum As Integer
  Dim tempchar As String
  
  Dim i As Integer
  
  For i = 1 To halfretsu
    tempnum = Cells(mototop + i - 1, 1).Value
    Cells(mototop + i - 1, 1).Value = ""
    tempchar = Cells(mototop + i - 1, 2).Value
    Cells(mototop + i - 1, 2).Value = ""
    
    Cells(atotop, i).Value = tempnum
    Cells(atotop, i + halfretsu).Value = tempchar
  Next
  
End Sub

をコピーして貼り付けてください。
その後上書き保存をしてVisual Basic Editorを閉じてください。

ツール(T)→マクロ(M)→マクロ(M)
または
Alt+F8
で呼び出したウィンドウの
irekae
を選んで
実行(R)
をクリックしてください。

回答に対する補足にあるアルゴリズムだと無駄があるので一部を省いて結果として同じになるものになってるはずです。

この回答への補足

すみません!使えました!
私が2回貼り付けボタンを押していたようですm(__;)m
Visual Basic Editorの使用方法もあり大変わかりやすいです。
そこでちょっと相談なのですが、元データの途中に空行がある場合、並べ替え後データも空行を作ることはできるでしょうか?

1      1234

3      567

   →




という感じで1行10個なくても改行になり、さらに1行空行を入れてまた続きが入る。

なんとかなりますでしょうか・・・

補足日時:2003/05/17 02:21
    • good
    • 0
この回答へのお礼

お答えありがとうございます
試してみたところ残念ながらコンパイルエラーがでてirekaeが使えませんでした

お礼日時:2003/05/17 02:11

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング