MACRO runs awfully slow!

P

powerwill

Board Regular
Joined
Sep 14, 2018
Messages
62
Office Version
  1. 365
Platform
  1. Windows
I am working on a file with this Macro. This macro copies the data from a form (sheet1) and pastes it horizontally on a blank row in the next sheet. But this is awfully slow..is there anything you guys would recommend to make it run quicker?

Office version: 365

VBA Code: 
Sub SubmitDataWAF()'' SubmitDataWAF Macro' '    ActiveCell.Offset(-2, -2).Range("A1").Select    Range(Selection, Selection.End(xlDown)).Select    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _        xlNone, SkipBlanks:=False, Transpose:=True    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(8, -2).Range("A1").Select    Range(Selection, Selection.End(xlDown)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _        xlNone, SkipBlanks:=False, Transpose:=True    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(4, 4).Range("A1").Select    Range(Selection, Selection.End(xlDown)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _        xlNone, SkipBlanks:=False, Transpose:=True    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveWindow.SmallScroll Down:=39    ActiveCell.Offset(45, -6).Range("A1:A4").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _        xlNone, SkipBlanks:=False, Transpose:=True    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(0, 2).Range("A1:A4").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _        xlNone, SkipBlanks:=False, Transpose:=True    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(0, 2).Range("A1:A4").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _        xlNone, SkipBlanks:=False, Transpose:=True    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(0, 2).Range("A1:A4").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _        xlNone, SkipBlanks:=False, Transpose:=True    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveWindow.SmallScroll Down:=-24    ActiveCell.Offset(-39, -1).Range("A1:B1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, -1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1").Select    Range(Selection, Selection.End(xlToRight)).Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveWindow.SmallScroll Down:=18    ActiveCell.Offset(3, -3).Range("A1:E1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    ActiveCell.Offset(0, 5).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1:E1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    ActiveCell.Offset(0, 5).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1:E1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    ActiveCell.Offset(0, 5).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1:E1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1:E1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    ActiveCell.Offset(0, 1).Range("A1:C1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(-4, -3).Range("A1:C1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    ActiveSheet.Paste    ActiveCell.Offset(0, 3).Range("A1:C1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1:C1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveCell.Offset(-1, 0).Range("A1:C1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    ActiveCell.Offset(0, -3).Range("A1:C1").Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    ActiveCell.Offset(0, 3).Range("A1:C1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1:C1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    ActiveCell.Offset(0, 3).Range("A1:C1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1:C1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.End(xlToRight).Select    Selection.End(xlToLeft).Select    ActiveCell.Offset(0, 3).Range("A1:C1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1:C1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    ActiveCell.Offset(0, 3).Range("A1:C1").Select    ActiveSheet.Previous.Select    ActiveCell.Offset(1, 0).Range("A1:C1").Select    Application.CutCopyMode = False    Selection.Copy    ActiveSheet.Next.Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    ActiveCell.Offset(1, 0).Range("A1:C1").Select    Selection.End(xlToLeft).Select    ActiveCell.Select    Sheets("Quality Form").Select    ActiveWindow.SmallScroll Down:=-114    ActiveCell.Offset(-52, 7).Range("A1:A6").SelectEnd Sub
 
Sort by date Sort by votes
@powerwill
Give this code a try.
I have not been able to test it on a fully functioning pair of sheets but it should be ok.
Your use of merged cells for holding data is not best practice as far a s vba is concerned but it should be ok.
To avoid the user having to select column A of the next available row, I have assumed that column Y will always have a value if that row is populated?
You will need to remove the row of "x" from row 267 as that is a confusing issue. If you cannot then let me know.
Format the various columns as applicable.

VBA Code: 
Sub SubmitDataWAF_2()
'Test only on backed up file
Dim WSQF As Worksheet
Dim WSAD As Worksheet
Dim NxtAr As Integer
Dim Arng As Range
Dim r As Integer, c As Integer

'suspend calculation
Application.Calculation = xlCalculationManual
'suspend screen refresh
Application.ScreenUpdating = False

Set WSAD = Sheets("Audit Data")
Set WSQF = Sheets("Quality Form")

'Next Row on Audit  **** Assumes column Y will always be populated if a record exists in row!!!?
NxtAr = WSAD.Range("Y" & Rows.Count).End(xlUp).Row + 1

With WSAD
.Range("A" & NxtAr & ":P" & NxtAr) = Application.Transpose(WSQF.Range("F1:F17"))
.Range("Q" & NxtAr & ":X" & NxtAr) = Application.Transpose(WSQF.Range("D9:D17"))
.Range("Y" & NxtAr & ":AB" & NxtAr) = Application.Transpose(WSQF.Range("H13:H17"))
'Overall attributes 1 -4
.Range("AC" & NxtAr & ":AF" & NxtAr) = Application.Transpose(WSQF.Range("B58:B61"))
.Range("AG" & NxtAr & ":AJ" & NxtAr) = Application.Transpose(WSQF.Range("D58:D61"))
.Range("AK" & NxtAr & ":AN" & NxtAr) = Application.Transpose(WSQF.Range("F58:F61"))
.Range("AO" & NxtAr & ":AR" & NxtAr) = Application.Transpose(WSQF.Range("H58:H61"))

'Sub Attributes 1 -30
Set Arng = .Range("AS" & NxtAr)
Set QFrng = WSQF.Range("G19")
c = 0
For r = 0 To 29
    Arng.Offset(0, c) = QFrng.Offset(r, 0)
    c = c + 1
    Arng.Offset(0, c) = QFrng.Offset(r, 1)
    c = c + 1
Next r

'Miscs
Set Arng = .Range("DA" & NxtAr & ":DE" & NxtAr)
Set QFrng = WSQF.Range("D51:H51")
' Miscs 2A - 5E
For r = 0 To 4
    Arng.Offset(0, r * 5) = QFrng.Offset(r, 0).Value
Next r

'Misc 1A -1E  and dealing with the merged cells
Set Arng = .Range("DZ" & NxtAr)

Set QFrng = WSQF.Range("A51")
For r = 0 To 4
    Arng.Value = QFrng.Offset(r, 0).Value
    Set Arng = Arng.Offset(0, 1)
Next r

End With
're-establish calc and refresh
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Hope that helps.
 
Upvote 0

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Snakehips said:
@powerwill
Give this code a try.
I have not been able to test it on a fully functioning pair of sheets but it should be ok.
Your use of merged cells for holding data is not best practice as far a s vba is concerned but it should be ok.
To avoid the user having to select column A of the next available row, I have assumed that column Y will always have a value if that row is populated?
You will need to remove the row of "x" from row 267 as that is a confusing issue. If you cannot then let me know.
Format the various columns as applicable.

VBA Code: 
Sub SubmitDataWAF_2()
'Test only on backed up file
Dim WSQF As Worksheet
Dim WSAD As Worksheet
Dim NxtAr As Integer
Dim Arng As Range
Dim r As Integer, c As Integer

'suspend calculation
Application.Calculation = xlCalculationManual
'suspend screen refresh
Application.ScreenUpdating = False

Set WSAD = Sheets("Audit Data")
Set WSQF = Sheets("Quality Form")

'Next Row on Audit  **** Assumes column Y will always be populated if a record exists in row!!!?
NxtAr = WSAD.Range("Y" & Rows.Count).End(xlUp).Row + 1

With WSAD
.Range("A" & NxtAr & ":P" & NxtAr) = Application.Transpose(WSQF.Range("F1:F17"))
.Range("Q" & NxtAr & ":X" & NxtAr) = Application.Transpose(WSQF.Range("D9:D17"))
.Range("Y" & NxtAr & ":AB" & NxtAr) = Application.Transpose(WSQF.Range("H13:H17"))
'Overall attributes 1 -4
.Range("AC" & NxtAr & ":AF" & NxtAr) = Application.Transpose(WSQF.Range("B58:B61"))
.Range("AG" & NxtAr & ":AJ" & NxtAr) = Application.Transpose(WSQF.Range("D58:D61"))
.Range("AK" & NxtAr & ":AN" & NxtAr) = Application.Transpose(WSQF.Range("F58:F61"))
.Range("AO" & NxtAr & ":AR" & NxtAr) = Application.Transpose(WSQF.Range("H58:H61"))

'Sub Attributes 1 -30
Set Arng = .Range("AS" & NxtAr)
Set QFrng = WSQF.Range("G19")
c = 0
For r = 0 To 29
    Arng.Offset(0, c) = QFrng.Offset(r, 0)
    c = c + 1
    Arng.Offset(0, c) = QFrng.Offset(r, 1)
    c = c + 1
Next r

'Miscs
Set Arng = .Range("DA" & NxtAr & ":DE" & NxtAr)
Set QFrng = WSQF.Range("D51:H51")
' Miscs 2A - 5E
For r = 0 To 4
    Arng.Offset(0, r * 5) = QFrng.Offset(r, 0).Value
Next r

'Misc 1A -1E  and dealing with the merged cells
Set Arng = .Range("DZ" & NxtAr)

Set QFrng = WSQF.Range("A51")
For r = 0 To 4
    Arng.Value = QFrng.Offset(r, 0).Value
    Set Arng = Arng.Offset(0, 1)
Next r

End With
're-establish calc and refresh
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Hope that helps.
Click to expand...
Thank you @Snakehips for making the code.

Unfortunately it didn't work on my backed up file. When I run the macro it does nothing.

But I have now attached a new file that you can take a look at, with all columns and cells formatted as they should be. I have filled three rows for your reference with the same data from the first sheet.

NEW FILE

Note: In the sheet 'Quality Form' the cells G19:H48 are pasted under The "Sub Attribute1-30" and their corresponding adjacent cells under "Remarks" in the next sheet 'Audit Data'. Just in case you didn't know this already.

Right now the active slow MACRO assigned to button 'Submit Data' works only when you select the cell that says "Click here to Activate"

Please let me know if the file looks good and if it helps you to fix this.

Thanks a ton!
 
Upvote 0
powerwill said:
Unfortunately it didn't work on my backed up file. When I run the macro it does nothing.
Click to expand...
I have tried it on the new file and it works perfectly well for me in a split second!
How did you run the code? You can run it direct from the vba editor in order to test it.
Otherwise, rename your slow macro as say Sub xxx ()
Rename the code I gave you as Sub SubmitDataWAF () Then your SUBMIT button will run the new code rather than your old.
Then, as I posted previously, you need to remove the row that is full of 'x's. If you do not remove the x row then my code will enter values way down below that row, which is both out of sight and unformatted!
Then test by hitting the SUBMIT button a couple of times.
If all is good then delete your old macro.
If you really do need to keep that row of 'x's then let me know and I will tweak the code.
 
Upvote 0
Snakehips said:
I have tried it on the new file and it works perfectly well for me in a split second!
How did you run the code? You can run it direct from the vba editor in order to test it.
Otherwise, rename your slow macro as say Sub xxx ()
Rename the code I gave you as Sub SubmitDataWAF () Then your SUBMIT button will run the new code rather than your old.
Then, as I posted previously, you need to remove the row that is full of 'x's. If you do not remove the x row then my code will enter values way down below that row, which is both out of sight and unformatted!
Then test by hitting the SUBMIT button a couple of times.
If all is good then delete your old macro.
If you really do need to keep that row of 'x's then let me know and I will tweak the code.
Click to expand...
Oh my God its flawless.

Yes Apologies, my dumbass did not clear the Xs, the values were getting pasted below it.

That works amazingly well!! I can't belive it!

I can't thank you enough @Snakehips
 
Upvote 0
powerwill said:
Oh my God its flawless.

Yes Apologies, my dumbass did not clear the Xs, the values were getting pasted below it.

That works amazingly well!! I can't belive it!

I can't thank you enough @Snakehips
Click to expand...
@powerwill Excellent! You are welcome.
Do you want me to have a word with the Moderators and see if we can change your username?
I do't think 'dumbass' is already taken. ;)
 
Upvote 0
Snakehips said:
@powerwill Excellent! You are welcome.
Do you want me to have a word with the Moderators and see if we can change your username?
I do't think 'dumbass' is already taken. ;)
Click to expand...
Okay, I don't know what went wrong but now the other macro that helps me take a screen shot of the "Quality Form" and pastes it in Sheet 3 is giving me an error.

I did the same thing previously selected the Range and did a paste special as Picture in Sheet3 ?
 
Upvote 0
powerwill said:
Okay, I don't know what went wrong but now the other macro that helps me take a screen shot of the "Quality Form" and pastes it in Sheet 3 is giving me an error.

I did the same thing previously selected the Range and did a paste special as Picture in Sheet3 ?
Click to expand...
VBA Code: 
Sub ScreenShot()

'

' ScreenShotWAF Macro

'

 

'

    Range("A1:I62").Select

    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    Sheets("Image Captured Here").Select

    Range("A1").Select

    ActiveSheet.Paste

    ActiveSheet.Shapes.Range(Array("Picture 1")).Select

    Sheets("Quality Form").Select

    Range("D9").Select

End Sub

@Snakehips this was the code. ?
 
Upvote 0
I notice that you have changed the sub name ? No WAF at end. That's ok provided that it's still assigned to your button?
However, try removing the line that selects ...."Picture 1" '****** as I imagine that it is somewhat unnecessary and will likely cause error if Picture 1 has been deleted.

VBA Code: 
Sub ScreenShot () '<<< ?????

' ScreenShotWAF Macro

    Range("A1:I62").Select

    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    Sheets("Image Captured Here").Select

    Range("A1").Select

    ActiveSheet.Paste

   ' ********  'ActiveSheet.Shapes.Range(Array("Picture 1")).Select. *********

    Sheets("Quality Form").Select

    Range("D9").Select

End Sub
 
Upvote 0
Snakehips said:
I notice that you have changed the sub name ? No WAF at end. That's ok provided that it's still assigned to your button?
However, try removing the line that selects ...."Picture 1" '****** as I imagine that it is somewhat unnecessary and will likely cause error if Picture 1 has been deleted.

VBA Code: 
Sub ScreenShot () '<<< ?????

' ScreenShotWAF Macro

    Range("A1:I62").Select

    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    Sheets("Image Captured Here").Select

    Range("A1").Select

    ActiveSheet.Paste

   ' ********  'ActiveSheet.Shapes.Range(Array("Picture 1")).Select. *********

    Sheets("Quality Form").Select

    Range("D9").Select

End Sub
Click to expand...

Snakehips said:
I notice that you have changed the sub name ? No WAF at end. That's ok provided that it's still assigned to your button?
However, try removing the line that selects ...."Picture 1" '****** as I imagine that it is somewhat unnecessary and will likely cause error if Picture 1 has been deleted.

VBA Code: 
Sub ScreenShot () '<<< ?????

' ScreenShotWAF Macro

    Range("A1:I62").Select

    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    Sheets("Image Captured Here").Select

    Range("A1").Select

    ActiveSheet.Paste

   ' ********  'ActiveSheet.Shapes.Range(Array("Picture 1")).Select. *********

    Sheets("Quality Form").Select

    Range("D9").Select

End Sub
Click to expand...
Yes that worked. Thank you again @Snakehips if you were in my country I would highly recommend your name to my Employer for an excel workshop.
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Insert formula in last column macro
2
Replies
13
Views
215
MARK858
MARK858
C
  • Question Question
Please help clean up my convoluted VBA code. It seems very redundant and repetitive.
Replies
1
Views
441
myall_blues
myall_blues
D
  • Solved
VBA If statement to continue
2
Replies
17
Views
653
dinunan
D
E
  • Solved
macro for copying values to the next blank cell
Replies
5
Views
463
Micron
M
S
  • Question Question
Dynamic Address by VBA
Replies
8
Views
212
MikeVol
MikeVol

Forum statistics

Threads
1,224,827
Messages
6,181,194
Members
453,021
Latest member
pingpong7117

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