MACRO runs awfully slow!

powerwill

New Member
Joined
Sep 14, 2018
Messages
31
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
 

Snakehips

Well-known Member
Joined
May 17, 2009
Messages
5,371
Office Version
  1. 2013
Platform
  1. Windows
@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.
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

powerwill

New Member
Joined
Sep 14, 2018
Messages
31
Office Version
  1. 365
Platform
  1. Windows
@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.
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!
 

Snakehips

Well-known Member
Joined
May 17, 2009
Messages
5,371
Office Version
  1. 2013
Platform
  1. Windows
Unfortunately it didn't work on my backed up file. When I run the macro it does nothing.
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.
 

powerwill

New Member
Joined
Sep 14, 2018
Messages
31
Office Version
  1. 365
Platform
  1. Windows
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.
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
 

Snakehips

Well-known Member
Joined
May 17, 2009
Messages
5,371
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

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
@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. ;)
 

powerwill

New Member
Joined
Sep 14, 2018
Messages
31
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

@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. ;)
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 😕
 

powerwill

New Member
Joined
Sep 14, 2018
Messages
31
Office Version
  1. 365
Platform
  1. Windows
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 😕
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. 😢
 

Snakehips

Well-known Member
Joined
May 17, 2009
Messages
5,371
Office Version
  1. 2013
Platform
  1. Windows
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
 

powerwill

New Member
Joined
Sep 14, 2018
Messages
31
Office Version
  1. 365
Platform
  1. Windows
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

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
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.
 

Forum statistics

Threads
1,143,835
Messages
5,721,060
Members
422,339
Latest member
SHIVATVM

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