ここから本文です

Excel VBAで、連続した整数の集計をし、重複した数を削除したいと思っています。

yuu2132さん

2018/12/2517:39:25

Excel VBAで、連続した整数の集計をし、重複した数を削除したいと思っています。

たとえば、
初めに[100~500]、[1000]と入力されたセルがあり、そこへ[400~1200]という数値が入力されたとき、その数値を[501~999]と[1001~1200]というふうに前に入力した数値と被らないような数に自動的に変換する。といったような感じです。

[100~500]など、~が入っている部分は、[100]と入力されたセルと、[500]と入力されたセルに分けていただいて構いません。

現状、いったん100から500と[1000]の整数をいったん配列に格納し、400から1200までの整数も2次元配列の2段目に入れ、Ifを使って同じものを0に置き換え、1づつ連続して上昇している最初の数と最後の数を出し、表示することで出来てはいるのですが、処理にとても時間がかかってしまっています。

つたない説明で大変申し訳ないのですが、ご回答お待ちしております。

閲覧数:
129
回答数:
2
お礼:
50枚

違反報告

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

30246kikuさん

2018/12/2707:14:02

回答し直してます

処理対象は、アクティブシート添付図の図上を図下にするものです
返信でも記述しましたが、細かいチェックはしていないので・・・・
動きが正しいのかは、検証は必須&修正スキルも必要です

確認は

新規ブックを開き、標準モジュールに以下を記述します
C1、D1 に新規の値を入力後、Samp1 or Samp2 を実行してみます
C1、D1 にドンドン新しい範囲を設定し実行してみます

Samp1:
新規の値の範囲を、旧値の範囲で加工していくもの

Samp2:
初期回答で紹介した方法で、作業列に E 列を使って・・・
※ 変形として、"A" の設定ではなくクリア・・・固定値のみ抽出でも

※※ 本当に細かいチェックはしていないので・・・
※※ 値の範囲の指定順・・・C1:1200、D1:400 逆ならポン・・・・とかとか
※※ Samp1 では、マイナス値の範囲も動くかも?・・・ただ、0 の扱い・・・

どうなりますか


Option Explicit

Private Type myData
   L As Long
   H As Long
   Next As Long
   Prev As Long
End Type

Public Sub Samp1()
   Dim tpA() As myData
   Dim jTop As Long, jL As Long, jH As Long
   Dim i As Long, k As Long, m As Long, n As Long

   m = 1
   ReDim tpA(0 To m)
   tpA(m).L = Range("C1").Value
   tpA(m).H = Range("D1").Value
   If (tpA(m).H = 0) Then tpA(m).H = tpA(m).L
   Range("C1:D1").ClearContents
   jTop = m

   For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
      If (Cells(i, "A").Value = "") Then Exit For
      jL = Cells(i, "A").Value
      jH = Cells(i, "B").Value
      If (jH = 0) Then jH = jL
      n = jTop
      While (n > 0)
         If (jH < tpA(n).L) Then
            n = 0
         ElseIf (tpA(n).H < jL) Then
            n = tpA(n).Next
         ElseIf ((jL <= tpA(n).L) And (tpA(n).H <= jH)) Then
            tpA(tpA(n).Next).Prev = tpA(n).Prev
            tpA(tpA(n).Prev).Next = tpA(n).Next
            If (jTop = n) Then jTop = tpA(n).Next
            n = tpA(n).Next
         ElseIf ((tpA(n).L < jL) And (jH < tpA(n).H)) Then
            m = m + 1
            ReDim Preserve tpA(0 To m)
            tpA(m).L = jH + 1
            tpA(m).H = tpA(n).H
            tpA(m).Next = tpA(n).Next
            tpA(m).Prev = n
            tpA(n).H = jL - 1
            tpA(n).Next = m
            n = 0
         ElseIf (jL <= tpA(n).L) Then
            tpA(n).L = jH + 1
            n = 0
         Else
            tpA(n).H = jL - 1
            n = tpA(n).Next
         End If
      Wend
   Next

   n = jTop
   While (n > 0)
      Cells(i, "A").Value = tpA(n).L
      If (tpA(n).L <> tpA(n).H) Then
         Cells(i, "B").Value = tpA(n).H
      End If
      i = i + 1
      n = tpA(n).Next
   Wend
End Sub


Public Sub Samp2()
   Dim rngs As Range, rng As Range, r As Range
   Dim vA As Variant
   Dim sS As String
   Dim jL As Long, jH As Long
   Dim i As Long, k As Long

   Set rng = Columns("E").Cells ' 作業列
   sS = rng(1).Address
   sS = Left(sS, InStrRev(sS, "$"))

   Application.ScreenUpdating = False
   rng.ClearContents
   jL = Range("C1").Value
   jH = Range("D1").Value
   If (jH = 0) Then jH = jL
   Range("C1:D1").ClearContents
   Range(rng(jL), rng(jH)).Value = 1

   For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
      If (Cells(i, "A").Value = "") Then Exit For
      jL = Cells(i, "A").Value
      jH = Cells(i, "B").Value
      If (jH = 0) Then jH = jL
      Range(rng(jL), rng(jH)).Value = "A"
   Next

   On Error Resume Next
   Set rngs = rng.SpecialCells(xlCellTypeConstants, xlNumbers)
   On Error GoTo 0
   If (Not rngs Is Nothing) Then
      ReDim vA(1 To rngs.Areas.Count, 1 To 1)
      k = 0
      For Each r In rngs.Areas
         k = k + 1
         vA(k, 1) = r.Address
      Next

      With Cells(i, "A").Resize(k)
         .Value = vA
         .TextToColumns .Cells(1), xlDelimited _
            , Other:=True, OtherChar:=":"
         .Resize(, 2).Replace sS, "", xlPart
      End With
   End If
   rng.ClearContents
   Application.ScreenUpdating = True
End Sub



以下、初期回答 2018/12/25 20:49:07

考え方だけで良いですか?

どのかのシート1列を作業用に使えば楽かも??

A 列を作業用に使うとして・・・処理手順として、

新しい範囲 400~1200 なら、A400~A1200 に 1 を設定
過去の範囲 100~500 は、A100~A500 に "A" を設定
1000 は、A1000 に "A" を設定
その A 列内の 数値部分を
SpecialCells(xlCellTypeConstants, xlNumbers)
で入手すれば・・・
数値で入手できた範囲が求めたい範囲・・・・


返信部分は・・・・・割愛

回答し直してます

処理対象は、アクティブシート添付図の図上を図下にするものです...

  • 質問者

    yuu2132さん

    2018/12/2800:56:56

    無事にできました!ありがとうございました!

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

  • 取り消す
  • キャンセル

質問した人からのコメント

2018/12/28 00:58:25

他の方も、しっかりとご教授いただき、とても参考になりました。ご教授いただいた方々、本当にありがとうございました!
今回は、実際に使用させていただいたことが理由で、ベストアンサーとさせていただきました。

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

1〜1件/1件中

webnaveさん

2018/12/2518:19:28

>初めに[100~500]、[1000]と入力されたセルがあり、そこへ[400~1200]という数値が入力されたとき

セルに直接入力すると[100~500]、[1000]のデータが消えるので
直前の入力されたデータを保存しておくセルが必要になりますが?
---
[100~500]、[1000]

このデータが1つのセルに入っているって事ですよね?
そのセルに
[400~1200] と入力して

最終結果がどのような表示にしたいのかな?

[100~1201]?

[ ]←これも必要なのかな?

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

  • 取り消す
  • キャンセル

この質問につけられたタグ

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

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

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

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

閉じる

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

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

閉じる