I'm looking to clean up a macro I made...

jjacks60

New Member
Joined
Jul 28, 2014
Messages
40
HTML:
Sub PasteRCdata()        Dim ws As Worksheet    Dim WsFc As Worksheet    Dim cell As Range    Dim Lastrow As Long    Dim X As Integer

    Set ws = Workbooks("Raw Data Production").Worksheets("Production Data") 'Raw Production Data    Set WsFc = Workbooks("Raw Data Production").Worksheets("Raw Data") 'Destination of Raw Data         Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row 'Setting last row of column A to use as lower bound X        For X = 1 To Lastrow        If cells(X, 1).Interior.ColorIndex = 6 Then        ' If the cell is yellow AND            If cells(X, 1).Value <> "" Then            'AND if the cell does not contain 'nothing'                cells(X, 1).Offset(2, 12).Select                'Then offset the cell by this exact amount every time... If this can be acheived without offset then that's okay                    If ActiveCell.Interior.ColorIndex = 34 Then                    'If this cell is light blue then I want it to copy and paste into the workbook WsFc.Range("B" & Rows.Count).End(xlUp).Offset(1).Select                    Range(Selection, Selection.End(xlToRight)).Select                        Application.CutCopyMode = False                        Selection.Copy Destination:=Workbooks("Raw Data Production").Worksheets("Raw Data") _                        .Range("B" & Rows.Count).End(xlUp).Offset(1, 0)                        'Here I want to add all cells to the right to copy and paste IF they are light blue, then transpose them into column B...                    End If            End If        End If    Next XEnd Sub

With regard to cleaning this up, anyone that has a keen eye do you see anything I can connect; Should there maybe be a function to reference from a lower sub would that help?

I tried to label what everything is doing with text.

I'm new to building code and I finally got this to work, so I'm not trying to mess it up.

If you also know how to transpose this paste function to keep values/format and skip blanks that would be amazing - it would also shorten the code I think.
"Range(Selection, Selection.End(xlToRight)).Select Application.CutCopyMode = False
Selection.Copy Destination:=Workbooks("Raw Data Production").Worksheets("Raw Data") _
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)"

</div>
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

hiker95

Well-known Member
Joined
Apr 8, 2009
Messages
17,649
jjacks60,

To start off can you re-post your macro code?


When posting VBA code, please use Code Tags - like this:

[code=rich]

'Paste your code here.

[/code]
 

jjacks60

New Member
Joined
Jul 28, 2014
Messages
40
jjacks60,

To start off can you re-post your macro code?


When posting VBA code, please use Code Tags - like this:

[code=rich]

'Paste your code here.

[/code]

Rich (BB code):
Sub PasteRCdata()
    
    Dim ws As Worksheet
    Dim WsFc As Worksheet
    Dim cell As Range
    Dim Lastrow As Long
    Dim X As Integer
    Dim MsgBoxResult As Long


    MsgBoxResult = MsgBox("Do NOT exctract data more than once per day - leads to data duplication errors", vbOKCancel, "Warning")
        If MsgBoxResult = vbCancel Then
        Exit Sub
        ElseIf MsgBoxResult = vbOK Then
    
    
    Set ws = Workbooks("Raw Data Production").Worksheets("Production Data") 'Raw Production Data
    Set WsFc = Workbooks("Raw Data Production").Worksheets("Raw Data") 'Destination of Raw Data
     
    Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row 'Setting last row of column A to use as lower bound X
    
    For X = 1 To Lastrow
        If cells(X, 1).Interior.ColorIndex = 6 Then
        ' If the cell is yellow AND
            If cells(X, 1).Value <> "" Then
            'AND if the cell does not contain 'nothing'
                cells(X, 1).Offset(2, 12).Select
                'Then offset the cell by this exact amount every time... If this can be acheived without offset then that's okay
                    If ActiveCell.Interior.ColorIndex = 34 Then
                    'If this cell is light blue then I want it to copy and paste into the workbook WsFc.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
                    Range(Selection, Selection.End(xlToRight)).Select
                        Application.CutCopyMode = False
                        Selection.Copy Destination:=Workbooks("Raw Data Production").Worksheets("Raw Data") _
                        .Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
                        'Here I want to add all cells to the right to copy and paste IF they are light blue, _
                        then transpose them into column B...
                    End If
            End If
        End If
    Next X
    WsFc.Select
    End If
End Sub

Wow sorry I had no idea it would post like that.

Again though just looking to shorten the code, maybe add a few sub that I can reference (like the message box I think), and figure out how to change the current copy paste method to a paste special that transposes and skips blanks IF the cell is light blue.
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
20,179
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
Maybe this... UNTESTED
It looks like you are working in the one workbook...if that is the case it can be shortened further
Code:
Sub PasteRCdata()
Dim ws As Worksheet, WsFc As Worksheet, cell As Range
Dim Lastrow As Long, X As Integer, MsgBoxResult As Long
MsgBoxResult = MsgBox("Do NOT exctract data more than once per day - leads to data duplication errors", vbOKCancel, "Warning")
    If MsgBoxResult = vbCancel Then Exit Sub
Set ws = Workbooks("Raw Data Production").Worksheets("Production Data") 'Raw Production Data
Set WsFc = Workbooks("Raw Data Production").Worksheets("Raw Data") 'Destination of Raw Data
Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row 'Setting last row of column A to use as lower bound X
For X = 1 To Lastrow
    If Cells(X, 1).Interior.ColorIndex = 6 And Cells(X, 1).Value <> "" Then
            Cells(X, 1).Offset(2, 12).Select
                If Cells(X, 1).Offset(2, 12).Interior.ColorIndex = 34 Then
                Rows(X).Copy Destination:=Workbooks("Raw Data Production").Worksheets("Raw Data").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
                End If
    End If
Next X
WsFc.Select
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,130,117
Messages
5,640,208
Members
417,131
Latest member
Seanr19871

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
Top