Copy value in text format to different cells based on pattern matching [closed]

Question

Closed. This question needs debugging details. It is not currently accepting answers.

---

Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.

Closed 7 years ago.

Improve this question

This is my data starting from column A from row-1

Question 1) Need formula for counting rows which has pattern matching for first 3 characters as 000,010,020,999 ??

In the above example it will be 5 and these 5 rows are header of a file; that means I have only 11 rows of data in which first 3 characters are 030

Question 2) Need macro to copy the above data of column A to other column's G,H,I,J,K,L,M and N as per below rule starting from row 2 to row 12

COLUMN B ===> start="4" length="5" where Record Type = 000  
COLUMN C ===> start="20" length="8" format="MMddyyyy" where Record Type = 000  
COLUMN D ===> start="28" length="3" where Record Type = 000  
COLUMN E ===> start="4" length="25" where Record Type = 010  
COLUMN F ===> start="60" length="20" where Record Type = 010  
COLUMN G ===> start="12" length="15" where Record Type = 020  
COLUMN H ===> start="65" length="1" where Record Type = 020  
COLUMN I ===> start="66" length="25" where Record Type = 020  
COLUMN J ===> start="4" length="30" where Record Type = 030   
COLUMN K ===> start="34" length="30" where Record Type = 030  
COLUMN L ===> start="64" length="30" where Record Type = 030  
COLUMN M ===> start="94" length="30" where Record Type = 030  
COLUMN N ===> start="154" length="23" where Record Type = 030  

o/p for the above rules will be only for 11 rows and it will be as below.

I have created a macro but the loop for the vaules in respective columns is giving me more output then the no of rows i.e. 11

I think some issue in the loop.

Macro -  

 Sub Macro_CopyData()

 'clear contents before every run

 Range("B1:X10000").Select
 Selection.ClearContents

 ' converting all fields to text

 Range("B1:X100000").NumberFormat = "@"

Dim myrange, cell As Range

 Dim i, j, k, l As Integer, count, count2 As Integer, ColumnA, ColumnB, ColumnC, data3,   ColumnD, ColumnE, ColumnF, ColumnG, ColumnH, ColumnI, ColumnI, ColumnK, ColumnL, ColumnM  As Variant

'counting number of rows in column A

count = ActiveSheet.Range("A1").End(xlDown).Row
MsgBox count
Set myrange = ActiveSheet.Range("A1", Range("A1").End(xlDown))

  ' assigning column names

Cells(1, 2).Value = "ColumnA"
Cells(1, 3).Value = "ColumnB"
Cells(1, 4).Value = "ColumnC"
Cells(1, 5).Value = "ColumnD"
Cells(1, 6).Value = "ColumnE"
Cells(1, 7).Value = "ColumnF"
Cells(1, 8).Value = "ColumnG"
Cells(1, 9).Value = "ColumnH"
Cells(1, 10).Value = "ColumnI"
Cells(1, 11).Value = "ColumnJ"
Cells(1, 12).Value = "ColumnK"
Cells(1, 13).Value = "ColumnL"
Cells(1, 14).Value = "ColumnM"

  For Each cell In myrange
  ' assigning values to the variables
    ColumnA = Mid(cell.Value, 4, 5)
    ColumnB = Mid(cell.Value, 20, 8)
    ColumnC = Mid(cell.Value, 28, 3)
    ColumnD = Mid(cell.Value, 4, 25)
    ColumnE = Mid(cell.Value, 60, 20)
    ColumnF = Mid(cell.Value, 12, 15)
    ColumnG = Mid(cell.Value, 65, 1)
    ColumnH = Mid(cell.Value, 66, 25)
    ColumnI = Mid(cell.Value, 4, 30)
    ColumnJ = Mid(cell.Value, 34, 30)
    ColumnK = Mid(cell.Value, 64, 30)
    ColumnL = Mid(cell.Value, 94, 30)
    ColumnM = Mid(cell.Value, 154, 23)

  For i = 1 To count - 4
  If Left(cell.Value, 3) = "000" Then

   cell.Offset(i, 1).Value = ColumnA
   cell.Offset(i, 2).Value = ColumnB
   cell.Offset(i, 3).Value = ColumnC

   End If
    Next i


  For j = 0 To count - 5
  If Left(cell.Value, 3) = "010" Then
  cell.Offset(j, 4).Value = ColumnD
  cell.Offset(j, 5).Value = ColumnE

   End If
  Next j



  For k = -1 To count - 1

  If Left(cell.Value, 3) = "020" Then
  cell.Offset(k, 6).Value = ColumnF
  cell.Offset(k, 7).Value = ColumnG
  cell.Offset(k, 8).Value = ColumnH
 End If
 Next k


 For l = -2 To count

  If Left(cell.Value, 3) = "030" Then
   cell.Offset(l, 9).Value = ColumnI
   cell.Offset(l, 10).Value = ColumnJ
   cell.Offset(l, 11).Value = ColumnK
   cell.Offset(l, 12).Value = ColumnL
   cell.Offset(l, 13).Value = ColumnM

  End If
  Next l

  Next cell


  End Sub

Answer 1

EDIT: try this - I think it's close to what you're trying to do.

Sub Macro_CopyData()

    Dim sht As Worksheet, cell As Range, myRange As Range
    Dim arrHeaders, pre, rw As Range
    Dim A, B, C, D, E, F, G, H, I, J, K, L, M

    Set sht = ActiveSheet

    With sht.Range("B1:X10000")
        .ClearContents
        .NumberFormat = "@"
    End With

    arrHeaders = Array("ColumnA", "ColumnB", "ColumnC", "ColumnD", _
                       "ColumnE", "ColumnF", "ColumnG", "ColumnH", _
                       "ColumnI", "ColumnJ", "ColumnK", "ColumnL", _
                       "ColumnM")
    'place headers on sheet
    sht.Cells(1, 2).Resize(1, UBound(arrHeaders) + 1).Value = arrHeaders

    Set myRange = sht.Range(sht.Cells(2, 1), _
                      sht.Cells(Rows.count, 1).End(xlUp))

    For Each cell In myRange.Cells

        Set rw = cell.EntireRow
        pre = Left(cell.Value, 3)

        Select Case pre

            Case "000"
                A = Mid(cell.Value, 4, 5)
                B = Mid(cell.Value, 20, 8)
                C = Mid(cell.Value, 28, 3)

            Case "010"
                D = Mid(cell.Value, 4, 5)
                E = Mid(cell.Value, 20, 8)

            Case "020"
                F = Mid(cell.Value, 12, 15)
                G = Mid(cell.Value, 65, 1)
                H = Mid(cell.Value, 66, 25)

            Case "030"
                rw.Cells(2).Value = A
                rw.Cells(3).Value = B
                rw.Cells(4).Value = C
                rw.Cells(5).Value = D
                rw.Cells(6).Value = E
                rw.Cells(7).Value = F
                rw.Cells(8).Value = G
                rw.Cells(9).Value = H
                rw.Cells(10).Value = Mid(cell.Value, 4, 30)
                rw.Cells(11).Value = Mid(cell.Value, 34, 30)
                rw.Cells(12).Value = Mid(cell.Value, 64, 30)
                rw.Cells(13).Value = Mid(cell.Value, 94, 30)
                rw.Cells(14).Value = Mid(cell.Value, 154, 23)

         End Select

    Next cell

End Sub