Pulling Data and formatting Closed

Question

Hey all.  Its my first time posting here but I have been reading the forums for some time.

Currently I am trying to figure out how to simply report creation. This is how I plan to have it done.

I 4 categories, 'User Name', 'Date', 'Description' and 'Contact Info' currently being pasted from my website into Column A.  Only the username and contact info is a required field therefore I could get from two filled in request to all four.  Here is an example:

[U]WorkSheet 1[/U]

[B]Column A[/B]           [B]Column B[/B]
TEST TEST
Gibberish
3/27/2009
User Name                    Scorro1
Date                           10/11/08
Description                  Tribe Leader
Contact Info                 [email]scorro1@gmail.com[/email]
gibberish
gibberish
User Name                    Joe123
Description                  Tribe Menace
Contact Info                 [email]Joe123@gmail.com[/email]
lies and gibberish             blah blah
User Name                    Happy123
Contact Info                 [email]Happy123@gmail.com[/email]
almost info                    [email]blah@blah.com[/email]
etc etc
etc


I am writing a macro to loop through column A looking for one of the 4 keywords 'User Name', 'Date', 'Description' and 'Contact Info'.  If it finds any of them, it would copy the cell from the next column (on the immediate right) and paste it into a different worksheet in this format:

User Name      Date           Description       Contact Info
Scorro1         10/11/08      Tribe Leader     [email]Scorro1@gmail.com[/email]
Joe123                         Tribe Menace   [email]Joe123@gmail.com[/email]
Happy123                                              [email]happy123@gmail.com[/email]



Right now, there are spots that have strike throughs like this  [Use your imagination for a strikethru here :)]

Contact Info                 a-b-c-@-g-m-a-i-l-.-c-o-m [email]scorro1@gmail.com[/email]

and I use some code found on this site 

Sub Macro4()
Columns("B:B").Select
Dim X As Long
Dim C As Range
For Each C In Selection
For X = Len(C.Value) To 1 Step -1
If C.Characters(X, 1).Font.Strikethrough Then
C.Characters(X, 1).Delete
End If
Next
C.Value = Application.WorksheetFunction.Trim(C.Value)
Next
End Sub





And this is my starter attempt to create this process


Sub Macro5()
'
' Macro5 Macro
' Macro recorded 3/27/2009 by 10053068
'

'
    Dim c As Range
For Each c In Range("A:A")
    If InStr(c.Value, "application") Then
        Selection.Offset(0, 1).Select
        Selection.Copy
        Selection.Offset(0, 2) = ActiveSheet.Paste
        
    End If
Next
End Sub


Ill keep updating this post as the day progresses.  BTW this is for the online game Tribalwars.net :)

scorro1 · Answer

A little more towards fininshing.  But now it wont copy all the rows even if they are there once it finds a blank...


Sub Remove_Strike_Thru()
'
' Remove_Strike_Thru Macro
' Macro recorded 3/27/2009 by 10053068
'
' Keyboard Shortcut: Ctrl+t
'

'Removes Strike Thrus
Sheets("Sheet1").Select

Range("D1:D1000").Select
Dim X As Long
Dim C As Range
For Each C In Selection
For X = Len(C.Value) To 1 Step -1
If C.Characters(X, 1).Font.Strikethrough Then
C.Characters(X, 1).Delete
End If
Next
C.Value = Application.WorksheetFunction.Trim(C.Value)
Next

'Remove all formatting except changes in font and font size
     
     'Turn off screen updates to improve performance
    Application.ScreenUpdating = False
     
    With Selection
         'Remove cell colors
        .Interior.ColorIndex = xlNone
         
         'Remove all cell borders
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlNone
        .Borders(xlEdgeTop).LineStyle = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
         
         'Remove all special font properties and formatting
        With .Font
            .FontStyle = "Regular"
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
        End With
    End With
     
     'Restore screen updates to display changes
    Application.ScreenUpdating = True
    
    'Autofit all cells
    Cells.Select
    Cells.EntireColumn.AutoFit

  
  Dim DestSheet        As Worksheet
  Set DestSheet = Worksheets("Sheet2")
  
  Dim sRow       As Long     'row index on source worksheet
  Dim dRow       As Long     'row index on destination worksheet
  Dim sCount     As Long
  sCount = 0
  dRow = 1

  For sRow = 1 To Range("A65536").End(xlUp).Row
     'use pattern matching to find "Significant" anywhere in cell
     If Cells(sRow, "A") Like "Application Name" Then
        sCount = sCount + 1
        dRow = dRow + 1
        'copy cols A,F,E & D
        'B = B - 1
        'Cells(sRow, "A").Copy Destination:=Sheet5.Cells(dRow, "B")
        'B = B + 1
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "B")
        'Cells(sRow, "C").Copy Destination:=Sheet5.Cells(dRow, "C")
        'Cells(sRow, "D").Copy Destination:=Sheet5.Cells(dRow, "D")
     End If
  Next sRow
  
  dRow = 1
  For sRow = 1 To Range("A65536").End(xlUp).Row
     'use pattern matching to find "Significant" anywhere in cell
     If Cells(sRow, "A") Like "Priority" Then
        sCount = sCount + 1
        dRow = dRow + 1
        'copy cols A,F,E & D
        'Cells(sRow, "A").Copy Destination:=Sheet5.Cells(dRow, "C1")
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "C")
        'Cells(sRow, "C").Copy Destination:=Sheet5.Cells(dRow, "C")
        'Cells(sRow, "D").Copy Destination:=Sheet5.Cells(dRow, "D")
     End If
  Next sRow
  
  'Takes Ticket Method
  dRow = 1
  For sRow = 1 To Range("A65536").End(xlUp).Row
     'use pattern matching to find "Significant" anywhere in cell
     If Cells(sRow, "A") Like "Ticket Method" Then
        sCount = sCount + 1
        dRow = dRow + 1
        'copy cols A,F,E & D
        'Cells(sRow, "A").Copy Destination:=Sheet5.Cells(dRow, "D1")
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "D")
     End If
  Next sRow
  
  'Takes Date Reported
      dRow = 1
  For sRow = 1 To Range("A65536").End(xlUp).Row
     'use pattern matching to find "Significant" anywhere in cell
     If Cells(sRow, "A") Like "Date Reported" Then
        sCount = sCount + 1
        dRow = dRow + 1
        'copy cols A,F,E & D
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "E")
     End If
  Next sRow
  
    'Takes Type
      dRow = 1
  For sRow = 1 To Range("A65536").End(xlUp).Row
     'use pattern matching to find "Significant" anywhere in cell
     If Cells(sRow, "A") Like "Type" Then
        sCount = sCount + 1
        dRow = dRow + 1
        'copy cols A,F,E & D
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "F")
     End If
  Next sRow
  
      'Takes Requestor Name
      dRow = 1
  For sRow = 1 To Range("A65536").End(xlUp).Row
     'use pattern matching to find "Significant" anywhere in cell
     If Cells(sRow, "A") Like "Requestor Name" Then
        sCount = sCount + 1
        dRow = dRow + 1
        'copy cols A,F,E & D
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "G")
     End If
  Next sRow
  
  
        'Takes Location Name
      dRow = 1
  For sRow = 1 To Range("A65536").End(xlUp).Row
     'use pattern matching to find "Significant" anywhere in cell
     If Cells(sRow, "A") Like "Location Name" Then
        sCount = sCount + 1
        dRow = dRow + 1
        'copy cols A,F,E & D
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "H")
     End If
  Next sRow
  
  
          'Takes Location Code
      dRow = 1
  For sRow = 1 To Range("A65536").End(xlUp).Row
     'use pattern matching to find "Significant" anywhere in cell
     If Cells(sRow, "A") Like "Location Code" Then
        sCount = sCount + 1
        dRow = dRow + 1
        'copy cols A,F,E & D
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "I")
     End If
  Next sRow
  
            'Takes Issue Description
      dRow = 1
  For sRow = 1 To Range("A65536").End(xlUp).Row
     'use pattern matching to find "Significant" anywhere in cell
     If Cells(sRow, "A") Like "Issue Description" Then
        sCount = sCount + 1
        dRow = dRow + 1
        'copy cols A,F,E & D
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "J")
     End If
  Next sRow
  
              'Takes   Resolution Notes
      dRow = 1
  For sRow = 1 To Range("A65536").End(xlUp).Row
     'use pattern matching to find "Significant" anywhere in cell
     If Cells(sRow, "A") Like "Resolution Notes" Then
        sCount = sCount + 1
        dRow = dRow + 1
        'copy cols A,F,E & D
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "K")
     End If
  Next sRow
  
  MsgBox sCount & " Significant rows copied", vbInformation, "Transfer Done"
Sheets("Sheet2").Select



End Sub

Pulling Data and formatting

1 response

Similar discussions

Subscribe To Our Newsletter!