VBA Code Help

D

danny8890

New Member
Joined
Feb 7, 2018
Messages
46
Hi,

I am currently using the below piece of code and it works without any problems.

I am wanting to make this a little better as currently it will move anything that is DIM to completed folder and then clears the contents in Sheet 1. The issue i've noticed is that some new subjects are coming in and they don't get copied as not created a DIM for them.

Is there anyway i can get this code to only move and clear the ones that were in DIM? rather than clear the whole sheets contents?

Thanks in advance


Code: 
Sub New_MagicMacro()Dim i As Long, lastRow As Long
Dim sh As Worksheet


Dim j As Long, My_AH, My_SIM(), SIMcount As Long, My_DUP(), DUPcount As Long, My_UNL(), UNLcount As Long, My_DIS(), DIScount _
As Long, My_PORT(), PORTcount As Long, My_AGE(), AGEcount As Long, My_DDD(), DDDcount As Long, My_DISE(), DISEcount _
As Long, My_Bar(), BARcount As Long, My_PAC(), PACcount As Long, My_MIG(), MIGcount As Long, My_POP(), POPcount _
As Long, My_POU(), POUcount As Long, My_REC(), RECcount As Long, My_TOO(), TOOcount As Long, DDMcount As Long, JUCcount As Long


lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Application.DisplayAlerts = False


Columns("F:F").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("G1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Selection.NumberFormat = "m/d/yyyy"
    Columns("H:I").Select
    Selection.ClearContents


My_AH = Range("A2:H" & lastRow).Value
ReDim My_SIM(1 To lastRow - 1, 1 To 7)
ReDim My_DUP(1 To lastRow - 1, 1 To 7)
ReDim My_UNL(1 To lastRow - 1, 1 To 7)
ReDim My_DIS(1 To lastRow - 1, 1 To 7)
ReDim My_PORT(1 To lastRow - 1, 1 To 7)
ReDim My_AGE(1 To lastRow - 1, 1 To 7)
ReDim My_DDD(1 To lastRow - 1, 1 To 7)
ReDim My_DISE(1 To lastRow - 1, 1 To 7)
ReDim My_Bar(1 To lastRow - 1, 1 To 7)
ReDim My_PAC(1 To lastRow - 1, 1 To 7)
ReDim My_MIG(1 To lastRow - 1, 1 To 7)
ReDim My_POP(1 To lastRow - 1, 1 To 7)
ReDim My_POU(1 To lastRow - 1, 1 To 7)
ReDim My_REC(1 To lastRow - 1, 1 To 7)
ReDim My_TOO(1 To lastRow - 1, 1 To 7)
ReDim My_DDM(1 To lastRow - 1, 1 To 7)
ReDim My_JUC(1 To lastRow - 1, 1 To 7)


For i = 1 To lastRow - 1
  If (My_AH(i, 1) Like "*SIM*") Or (My_AH(i, 1) Like "*SSN*") Or (My_AH(i, 1) Like "*Sim*") Or (My_AH(i, 1) Like "*O2 Retail*") _
  Then
    SIMcount = SIMcount + 1
    For j = 1 To 7
      My_SIM(SIMcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Duplicate*" Then
    DUPcount = DUPcount + 1
    For j = 1 To 7
      My_DUP(DUPcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Unlatching*" Then
    UNLcount = UNLcount + 1
    For j = 1 To 7
      My_UNL(UNLcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Dispute*" Then
    DIScount = DIScount + 1
    For j = 1 To 7
      My_DIS(DIScount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Port*" Then
    PORTcount = PORTcount + 1
    For j = 1 To 7
      My_PORT(PORTcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Age Verification*" Then
    AGEcount = AGEcount + 1
    For j = 1 To 7
      My_AGE(AGEcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Direct Debit Date*" Then
    DDDcount = DDDcount + 1
    For j = 1 To 7
      My_DDD(DDDcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*DISE to Pay*" Then
    DISEcount = DISEcount + 1
    For j = 1 To 7
      My_DISE(DISEcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Handset Barring*" Then
    BARcount = BARcount + 1
    For j = 1 To 7
      My_Bar(BARcount, j) = My_AH(i, j)
    Next j
  End If
   If My_AH(i, 1) Like "*PAC Request*" Then
    PACcount = PACcount + 1
    For j = 1 To 7
      My_PAC(PACcount, j) = My_AH(i, j)
    Next j
  End If
  If (My_AH(i, 1) Like "*Pay & Go to Pay Monthly Migration*") Or (My_AH(i, 1) Like "*Pay And Go To Pay Monthly Migration*") Then
    MIGcount = MIGcount + 1
    For j = 1 To 7
      My_MIG(MIGcount, j) = My_AH(i, j)
    Next j
  End If
  If (My_AH(i, 1) Like "*Proof of Purchase*") Then
    POPcount = POPcount + 1
    For j = 1 To 7
      My_POP(POPcount, j) = My_AH(i, j)
    Next j
  End If
   If (My_AH(i, 1) Like "*Proof of Usage*") Then
    POUcount = POUcount + 1
    For j = 1 To 7
      My_POU(POUcount, j) = My_AH(i, j)
    Next j
  End If
  If (My_AH(i, 1) Like "*Reconnection*") Then
    RECcount = RECcount + 1
    For j = 1 To 7
      My_REC(RECcount, j) = My_AH(i, j)
    Next j
  End If
   If (My_AH(i, 1) Like "*Transfer of ownership*") Then
    TOOcount = TOOcount + 1
    For j = 1 To 7
      My_TOO(TOOcount, j) = My_AH(i, j)
    Next j
  End If
  If (My_AH(i, 1) Like "*Direct Debit Mandate Request*") Then
    DDMcount = DDMcount + 1
    For j = 1 To 7
      My_DDM(DDMcount, j) = My_AH(i, j)
    Next j
  End If
  If (My_AH(i, 1) Like "*JUC Cease*") Then
    JUCcount = JUCcount + 1
    For j = 1 To 7
      My_JUC(JUCcount, j) = My_AH(i, j)
    Next j
  End If
  
Next i
If SIMcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(SIMcount, 7).Value = My_SIM
If DUPcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(DUPcount, 7).Value = My_DUP
If UNLcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UNLcount, 7).Value = My_UNL
If DIScount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(DIScount, 7).Value = My_DIS
If PORTcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(PORTcount, 7).Value = My_PORT
If AGEcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(AGEcount, 7).Value = My_AGE
If DDDcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(DDDcount, 7).Value = My_DDD
If DISEcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(DISEcount, 7).Value = My_DISE
If BARcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(BARcount, 7).Value = My_Bar
If PACcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(PACcount, 7).Value = My_PAC
If MIGcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(MIGcount, 7).Value = My_MIG
If POPcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(POPcount, 7).Value = My_POP
If POUcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(POUcount, 7).Value = My_POU
If RECcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(RECcount, 7).Value = My_REC
If TOOcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(TOOcount, 7).Value = My_TOO
If DDMcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(DDMcount, 7).Value = My_DDM
If JUCcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(JUCcount, 7).Value = My_JUC


Sheets("Sheet1").Range("A2:G50000").ClearContents


For Each sh In Worksheets
    If sh.Name <> "Lookup" Then
    If sh.Name <> "Sheet1" Then
    If sh.Name <> "Sheet2" Then
    If sh.Name <> "Sheet3" Then
    sh.Cells.WrapText = False
    sh.Range("H2:N2").AutoFill Destination:=sh.Range("H2:N" & sh.Range("A" & Rows.Count).End(xlUp).Row)
    sh.Columns("$A:$K").RemoveDuplicates Columns:=Array(1), Header:=xlYes
End If
End If
End If
End If
Next sh


MsgBox "Finished"
End Sub
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
On option would be to add this line
Code: 
For j = 1 To 7
  My_SIM(SIMcount, j) = my_AH(i, j)
 [COLOR=#0000ff] my_AH(i, j) = ""[/COLOR]
Next j
to all your For j loops & then write the array back to the sheet, after clearing it.
 
Upvote 0
Hi,

Thanks for you reply, So Would this only write it back to the sheet if it hasn't been copied to "Complete" if i write the array back to the sheet

Fluff said:
On option would be to add this line
Code: 
For j = 1 To 7
  My_SIM(SIMcount, j) = my_AH(i, j)
 [COLOR=#0000ff] my_AH(i, j) = ""[/COLOR]
Next j
to all your For j loops & then write the array back to the sheet, after clearing it.
Click to expand...
 
Last edited:
Upvote 0
That's simply clearing values in the original array is they are being copied to a new array.
So the only data left in the original array will be the stuff that did not get copied.
You'll need to either sort the data after copying back to the sheet, or delete blank rows.
 
Upvote 0
Makes sense thanks, I've added the extra line of code back in, I've had a go at trying to write the array back after clear contents but to no luck, had a search around too but still not luck, Could you assist with the coded to write it array back?, not sure how to do it, The code i'm using was kindly re wrote to speed the process up to what i originally had i know how to add new stuff to this and amend but still learning in terms of writing new code.

Thanks
 
Last edited:
Upvote 0
try
Code: 
Sheets("Sheet1").Range("A2").Resize(UBound(My_AH), 8).Value = My_AH
 
Upvote 0
Also added line of code to remove all the blank rows :)

Code: 
sh.Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
VBA Automatic Row Movement With Several Criteria
2
Replies
11
Views
697
Joe4
Joe4
J
  • Solved
Changing Worksheet Name to apply formulas based on cell reference entry
Replies
4
Views
65
Joe4
Joe4
S
  • Solved
Copy Textbox values from UserForm to the worksheet
Replies
6
Views
337
AlphaFrog
AlphaFrog
2
  • Question Question
Compare columns with discontinuous data.
Replies
3
Views
139
24August
2
A
  • Solved
doesn't show data in listbox on form without any error in this code
Replies
6
Views
222
Abdo
A

Forum statistics

Threads
1,225,489
Messages
6,185,284
Members
453,285
Latest member
Wullay

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top