ここから本文です

Excelでデータをまとめたいのですが、 膨大のデータのためマクロを使用しようと考...

アバター

ID非公開さん

2018/8/214:50:27

Excelでデータをまとめたいのですが、
膨大のデータのためマクロを使用しようと考えています

困っていることは

計測時にデータが左詰めになってしまい本来0の所が埋め込まれています図にもあるように四角のブロックを右にずらすことができますか?

補足この値は列でx,y,zの順で値が出てるんですが列で急に大きく異なった値になったら
3列分ずらすということが本当はしたいのですが、できますでしょうか?ちなみに
この写真は3×3がずれていますが
実際は1×3の時もあります

1 To UBound,varData,左詰め,As Variant,Dim r As Long,データ,Sub sample

この質問は、活躍中のチエリアン・専門家に回答をリクエストしました。

閲覧数:
260
回答数:
2
お礼:
250枚

違反報告

ベストアンサーに選ばれた回答

kik********さん

2018/8/316:58:51

son********さん で良かったですか?

B ~ D 列の前後を比較するだけで良かったですか

標準モジュールに以下を記述し Samp1 を実行してみます
処理対象はアクティブシートの B2 ~ のデータ・・・・

雰囲気、どうなりますか


Option Explicit

Public Sub Samp1()
   Dim vA As Variant
   Dim r As Range
   Dim i As Long, j As Long, k As Long
   Const CCW As Long = 3 ' 列数

   Application.ScreenUpdating = False
   With ActiveSheet
      j = .Cells(Rows.Count, "B").End(xlUp).Row
      vA = .Columns("B").Resize(j, CCW).Value
      k = 0
      For i = 3 To j
         For j = 1 To CCW
            If (Abs(vA(i, j) - vA(i - 1, j)) > 5) Then Exit For
         Next
         If (j <= CCW) Then
            k = 1 - k
            If (k = 1) Then
               Set r = .Cells(i, "B")
            Else
               r.Resize(i - r.Row, CCW).Insert xlShiftToRight
               Set r = Nothing
            End If
         End If
      Next
      If (Not r Is Nothing) Then
         r.Resize(i - r.Row, CCW).Insert xlShiftToRight
      End If
   End With
   Application.ScreenUpdating = True
End Sub

  • アバター

    質問者

    ID非公開さん

    2018/8/317:18:12

    少ない範囲ですが
    できました

    ですが、本当はBからDのみではなく
    BからCAまでありまして
    それをだいたい1000行目までの範囲でずらしていただけたら嬉しいのですができますでしょうか
    他に細かいことなどは
    他の回答者の方にも書いてるのでもし参考になればみてください

  • その他の返信を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この回答は投票によってベストアンサーに選ばれました!

ベストアンサー以外の回答

1〜1件/1件中

jiy********さん

編集あり2018/8/316:23:42

--(回答を書き直しています)--
Option Explicit
Sub sample()
    Dim sh As Worksheet
    Dim lrow As Long, srow As Long, erow As Long
    Const cnsDivRws As Long = 100000
    
    Set sh = Sheets("Sheet1")
    lrow = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
    For srow = 2 To lrow Step cnsDivRws
        erow = srow + cnsDivRws - 1
        If erow > lrow Then
            erow = lrow
        End If
        Call sample_sub(sh, srow, erow)
    Next srow
End Sub
Sub sample_sub(prmSh As Worksheet, prmSrow As Long, prmErow As Long)
    Dim v1() As Variant, v2() As Variant, v3() As Variant
    Dim r As Long, c As Long, cc As Long, ccwk As Long, h As Long
    Const N As Long = 3
    
    With prmSh.Range("A" & prmSrow & ":BZ" & prmErow)
        v1 = .Value
        ReDim v2(1 To UBound(v1), 1 To Int((UBound(v1, 2) + N - 1) / N), 1 To N)
        ReDim v3(1 To UBound(v1), 1 To Int((UBound(v1, 2) + N - 1) / N))
        'データを3次元配列に格納
        For r = 1 To UBound(v2)
            c = 1
            For cc = 1 To UBound(v2, 2)
                For h = 1 To UBound(v2, 3)
                    v2(r, cc, h) = v1(r, c)
                    c = c + 1
                Next h
            Next cc
        Next r
        'ずらす箇所をチェック
        For r = 2 To UBound(v3)
            For cc = UBound(v3, 2) To 1 Step -1
                For h = 1 To 3
                    If Abs(v2(r, cc, h) - v2(r - 1, cc, h)) >= 5 Then
                        v3(r, cc) = 1
                        Exit For
                    End If
                Next h
            Next cc
        Next r
        '右にずらす
        For r = 2 To UBound(v3)
            For cc = UBound(v3, 2) To 1 Step -1
                If v3(r, cc) = 1 Then
                    For ccwk = UBound(v3, 2) To cc + 1 Step -1
                        For h = 1 To 3
                            v2(r, ccwk, h) = v2(r, ccwk - 1, h)
                        Next h
                    Next ccwk
                    For h = 1 To 3
                        v2(r, cc, h) = 0
                    Next h
                    
                End If
            Next cc
        Next r
        '3次元配列を2次元配列に戻す
        For r = 1 To UBound(v2)
            c = 1
            For cc = 1 To UBound(v2, 2)
                For h = 1 To UBound(v2, 3)
                    v1(r, c) = v2(r, cc, h)
                    c = c + 1
                Next h
            Next cc
        Next r
        .Value = v1
    End With
End Sub

--(以下当初の回答)--

データはB2セルから始まり、J列が最終列という前提です。
右側の0を数えて処理していますが、途中に0がある場合(例えばE2セルのみ0など)は考慮していません。
これでいかがでしょうか。

Sub sample()
    Dim sh As Worksheet
    Dim varData() As Variant
    Dim r As Long, c As Long
    Dim cntZero As Long, cntloop As Long
    
    Set sh = Sheets("Sheet1")
    With sh.Range("B2:J" & sh.Range("B" & sh.Rows.Count).End(xlUp).Row)
        varData = .Value
        For r = LBound(varData) To UBound(varData)
            cntZero = 0
            For c = UBound(varData, 2) To LBound(varData, 2) Step -1
                If varData(r, c) = 0 Then
                    cntZero = cntZero + 1
                Else
                    Exit For
                End If
            Next c
            For cntloop = cntZero To 1 Step -1
                For c = UBound(varData, 2) To 2 Step -1
                    varData(r, c) = varData(r, c - 1)
                Next c
                varData(r, 1) = 0
            Next cntloop
        Next r
        .Value = varData
    End With
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる