need to modify existing macro to extract specific columns only

fingermouse

Board Regular
Joined
Dec 13, 2013
Messages
117
Hi,
I have been tasked with amending an existing macro. I'll do my best to explain.

For context, users enter ref numbers into a column on an existing excel worksheet e.g. cells (B6 to
B100000). The user then clicks a button to activate the macro. The macro creates a new worksheet
containing all the data relating to those ref numbers. The data is extracted from a database table.
It is 86 columns long while the number of rows is dependent on the quantity of ref numbers requested.
The output sheet has column headers which never change.

Its probably worth mentioning that the ref numbers input can relate to two separate periods. Before
clicking the button which activates the macro, users have to select either 'ECO1' or 'ECO2' from 2
radio buttons. Depending on what is selected, the macro will output the data to either a worksheet
called 'ECO1 Results' or one called 'ECO2 Results'.This may / or may not not be critical to my task
but thought I should mention it anyway.

Ultimately what I want is this:

• Retain the existing macro (assigned to button 1)

• Create a new macro which will only output specific columns from the database. e.g. ( columns C, AR,
AL, BW, AQ) and output them to a new worksheet in that column order / sequence. (assigned to button
2).

Basically macro 2 should do everything macro 1 does. But instead of outputting all columns, it
outputs specified columns/ranges.

Here is the existing module code.

Code:
Sub UpdateQuery()
Application.Calculation = xlCalculationManual
StopSub = False

[COLOR=#008000]'1: check cell A1 contains 1 or 2
[/COLOR]
If Not Range("A1") = 1 Then
If Not Range("A1") = 2 Then MsgBox ("Error: Cell A1 should contain '1' for ECO1 or '2' for ECO2")
End If
ECOPeriod = Range("A1").Value

[COLOR=#008000]'2: Clear contents, check there's some MRNs in the list
[/COLOR]
Worksheets("ECO1 Results").Range("A2:BV1000000").ClearContents
Worksheets("ECO2 Results").Range("A2:CH1000000").ClearContents
If IsEmpty(Worksheets("List of MRNs").Range("B5")) Then End

[COLOR=#008000]'3:[/COLOR]
KeepPowerOn
ErrorTotal = 0
TotalMeasures = WorksheetFunction.Counta(Worksheets("List of MRNs").Range("B5:B1000000"))

[COLOR=#008000]'4: Start loop
[/COLOR]
For Counter = 1 To TotalMeasures

[COLOR=#008000]'5: Read MRN and enter it into relevant sheet
[/COLOR]
CurrentMRN = Worksheets("List of MRNs").Range("B4").Offset(Counter, 0).Value
If ECOPeriod = 1 Then
Worksheets("DWH Pivot & Workings").Range("F2").Value = CurrentMRN
End If
If ECOPeriod = 2 Then
Worksheets("DWH Pivot & Workings").Range("F23").Value = CurrentMRN
End If

[COLOR=#008000]'6: Calculate workings sheet
[/COLOR]
Worksheets("DWH Pivot & Workings").Calculate
DoEvents

[COLOR=#008000]'7: Update relevant table with new query
[/COLOR]
If ECOPeriod = 1 Then
On Error GoTo ErrorFound
With Worksheets("DWH Returns").Range("A3").ListObject.QueryTable
.Connection = Array( _
"OLEDB;Provider=MSOLAP.4;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=ECO;Data 
Source=lonp-ecoBe01;MDX Compatibi" _
, "lity=1;Safety Options=2;MDX Missing Member Mode=Error")
.CommandType = xlCmdDefault
.BackgroundQuery = False
.CommandText = Worksheets("DWH Pivot & Workings").Range("F8").Value
.Refresh

End With

End If

If ECOPeriod = 2 Then
On Error GoTo ErrorFound
With Worksheets("ECO2 Returns").Range("A3").ListObject.QueryTable
.Connection = Array( _
"Provider=MSOLAP.4;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=ECO2;Data 
Source=lonp-ECOBE01;MDX Compatibility=1;Safety Options=2;MDX Missing Member Mode=Error")
.CommandType = xlCmdDefault
.BackgroundQuery = False
.CommandText = Worksheets("DWH Pivot & Workings").Range("F32").Value
.Refresh

End With

End If

DoEvents
PasteRow = Counter + 1
DoEvents

[COLOR=#008000]'8: Copy results out
[/COLOR]
If ECOPeriod = 1 Then
ResultsPaste = "A" & PasteRow & ":BV" & PasteRow
Worksheets("DWH Returns").Range("A4:BV4").Copy
Worksheets("ECO1 Results").Range(ResultsPaste).PasteSpecial xlPasteValues
Worksheets("ECO1 Results").Visible = True
Worksheets("ECO1 Results").Activate
End If

If ECOPeriod = 2 Then
ResultsPaste = "A" & PasteRow & ":CH" & PasteRow
Worksheets("ECO2 Returns").Range("A4:CH4").Copy
Worksheets("ECO2 Results").Range(ResultsPaste).PasteSpecial xlPasteValues
Worksheets("ECO2 Results").Visible = True
Worksheets("ECO2 Results").Activate
End If

DoEvents

GoTo GoNext

[COLOR=#008000]'9: Error handling
[/COLOR]
ErrorFound:
ErrorTotal = ErrorTotal + 1
PasteRow = Counter + 1
If ECOPeriod = 1 Then
ResultsPaste = "A" & PasteRow & ":BV" & PasteRow
Worksheets("ECO1 Results").Range(ResultsPaste).Value = "NOT FOUND"
Worksheets("ECO1 Results").Range("D" & PasteRow).Value = Worksheets("List of MRNs").Range
("B4").Offset(Counter, 0).Value
Worksheets("ECO1 Results").Visible = True
Worksheets("ECO1 Results").Activate
End If

If ECOPeriod = 2 Then
ResultsPaste = "A" & PasteRow & ":CH" & PasteRow
Worksheets("ECO2 Results").Range(ResultsPaste).Value = "NOT FOUND"
Worksheets("ECO2 Results").Range("D" & PasteRow).Value = Worksheets("List of MRNs").Range
("B4").Offset(Counter, 0).Value
Worksheets("ECO2 Results").Visible = True
Worksheets("ECO2 Results").Activate
End If

Resume GoNext

[COLOR=#008000]'10 Update progress indicator
[/COLOR]
GoNext:
Progress.MeasuresRemaining = TotalMeasures - Counter
Progress.PercentComplete2 = (Counter / TotalMeasures) * 100
Progress.Repaint
If StopSub = True Then GoTo EndofSub
Next Counter
EndofSub:
If ErrorTotal > 0 Then MsgBox (ErrorTotal & " MRNs not found in DWH, marked as NOT FOUND")
StopTimer
Progress.Hide

End Sub

Hope I've explained all this ok. Apologies for the long winded email to what is (hopefully) not a
very complex macro, but I thought I should provide as much info as possible :)

Any help would be much appreciated. Regards, Cal.
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Hi,

if anyone could help with this it would be much appreciated, thanks.

Ive thought a bit more about this and I think this is all I need....

Below is the part of the code that copies and pastes A4:CH4:

Code:
'8: Copy results out

  
    If ECOPeriod = 2 Then
        ResultsPaste = "A" & PasteRow & ":CH" & PasteRow
[COLOR=#ff0000][B]        Worksheets("ECO2 Returns").Range("A4:CH4").Copy[/B][/COLOR]
        Worksheets("ECO2 Results").Range(ResultsPaste).PasteSpecial xlPasteValues
        Worksheets("ECO2 Results").Visible = True
        Worksheets("ECO2 Results").Activate

Is it possible to modify the code so that it copies and pastes columns D, C, AR, AL, BW etc.. only?

How could this be done?
 
Upvote 0

Forum statistics

Threads
1,213,565
Messages
6,114,337
Members
448,568
Latest member
Honeymonster123

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