Correction to original

Jamuson

New Member
Joined
Dec 18, 2020
Messages
4
Platform
  1. MacOS
I have a macro that works for the first instance of pasting into the new sheet. The problem is that when I offset the second sheet, I can't get both the ValuesAndNumberFormat and Format to "line up". Heres what I have...Im going to repeat the operation on 8 sheets total, to combine them into one with the original formatting...Im sure there is a way to Loop it to run through all the sheets and never paste over data, plus keep all the formatting.

VBA Code:
Sub Data_Scrubber()

Dim count_col, count_row As Integer
Dim orig, output As Worksheet

Worksheets("Sheet1").Activate

Set orig = ThisWorkbook.Sheets("Sheet1")
Set output = ThisWorkbook.Sheets("Corrections")

count_col = WorksheetFunction.CountA(Range("A2", Range("A2").End(xlToRight)))
count_row = WorksheetFunction.CountA(Range("A2", Range("A2").End(xlDown)))

ActiveSheet.Range("A2").AutoFilter Field:=1, Criteria1:="<>"

orig.Range(Cells(2, 1), Cells(count_row, count_col)).SpecialCells(xlCellTypeVisible).Copy
output.Cells(2, 1).PasteSpecial xlPasteValuesAndNumberFormats
output.Cells(2, 1).PasteSpecial xlPasteFormats
Application.CutCopyMode = False

Worksheets("Sheet2").Activate

Set orig = ThisWorkbook.Sheets("Sheet2")
Set output = ThisWorkbook.Sheets("Corrections")

count_col = WorksheetFunction.CountA(Range("A2", Range("A2").End(xlToRight)))
count_row = WorksheetFunction.CountA(Range("A2", Range("A2").End(xlDown)))

ActiveSheet.Range("A2").AutoFilter Field:=1, Criteria1:="<>"

orig.Range(Cells(2, 1), Cells(count_row, count_col)).SpecialCells(xlCellTypeVisible).Copy
output.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
output.Cell(2,1)PasteSpecial xlPasteFormats
Application.CutCopyMode = False



End Sub

Any help would be appreciated!
 

Some videos you may like

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

mse330

Well-known Member
Joined
Oct 18, 2007
Messages
711
Office Version
  1. 365
Platform
  1. Windows
Hi Jamuson,

Try below code ... We might need to do some adjustments as I am not sure if you have any data in row #1 of the sheets, does your data extends to more than one column with data, do you have headers in sheet 'Corrections' ... etc. Give it a try & let us know how it goes

VBA Code:
Sub test()

Dim ws As Worksheet, MainWs As Worksheet
Set MainWs = Sheets("Corrections")

For Each ws In Sheets(Array("Sheet1", "Sheet2", "Sheet3")) '<-- add sheet names where needed
   With ws.[A2].CurrentRegion
      .AutoFilter 1, "<>"
      .Offset(1).SpecialCells(12).Copy
         With MainWs.Range("A" & Rows.Count).End(3).Offset(1)
            .PasteSpecial xlPasteValuesAndNumberFormats
            .PasteSpecial xlPasteFormats
         End With
      .AutoFilter
   End With
Next

End Sub
 
Solution

Jamuson

New Member
Joined
Dec 18, 2020
Messages
4
Platform
  1. MacOS
Hi Jamuson,

Try below code ... We might need to do some adjustments as I am not sure if you have any data in row #1 of the sheets, does your data extends to more than one column with data, do you have headers in sheet 'Corrections' ... etc. Give it a try & let us know how it goes

VBA Code:
Sub test()

Dim ws As Worksheet, MainWs As Worksheet
Set MainWs = Sheets("Corrections")

For Each ws In Sheets(Array("Sheet1", "Sheet2", "Sheet3")) '<-- add sheet names where needed
   With ws.[A2].CurrentRegion
      .AutoFilter 1, "<>"
      .Offset(1).SpecialCells(12).Copy
         With MainWs.Range("A" & Rows.Count).End(3).Offset(1)
            .PasteSpecial xlPasteValuesAndNumberFormats
            .PasteSpecial xlPasteFormats
         End With
      .AutoFilter
   End With
Next

End Sub
Thanks so much! this worked perfectly!
I have one more function Im trying to work out.
Id like to click on a row in Sheet"MASTER" and run a quick key macro and copy the values from columns R,O and Q and paste them into the next available row on Sheet"CORRECTIONS" in columns A,B,C...Is this even possible?
 

mse330

Well-known Member
Joined
Oct 18, 2007
Messages
711
Office Version
  1. 365
Platform
  1. Windows
Try below code assuming you'll be in sheet 'MASTER' when running the macro
VBA Code:
Sub test()

With Sheets("CORRECTIONS").Range("A" & Rows.Count).End(3)(2).Resize(, 3)
    .Value = Array(Cells(ActiveCell.Row, "R"), Cells(ActiveCell.Row, "O"), Cells(ActiveCell.Row, "Q"))
End With

End Sub
 

Jamuson

New Member
Joined
Dec 18, 2020
Messages
4
Platform
  1. MacOS
Again this works amazing! I can't thank you enough. I'm quarantined in Japan away from my family and this helps a ton! Happy holidays to you and your family, stay safe!

Thanks again,

Jamuson
 

mse330

Well-known Member
Joined
Oct 18, 2007
Messages
711
Office Version
  1. 365
Platform
  1. Windows
Glad to help & thanks for your feedback ... Stay safe :)
 

Watch MrExcel Video

Forum statistics

Threads
1,127,098
Messages
5,622,682
Members
415,920
Latest member
ExcelNoob28

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