I have a code that copy values from a selected sheet to a master sheet. When the first run is completed; I need to select the second sheet. For some strange reason I need to perform it 3 or more times before it is correct. I've checked it over and over but couldn't find it.
It are two codes but linked to each other.
Can somebody help me?
Sub Update_SISdata_STB()
'
' Update_SISdata Macro
'
Set Workbook = ThisWorkbook
Sheets("Meetstaten").Select
WorkbooknameSISdata = ActiveWorkbook.Name
MsgBox "Selecteer de steigerbouwdump om te importeren ", vbMsgBoxSetForeground, "BIS Industrial Services"
Workbookname_ASESR = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Please select a file")
If Workbookname_ASESR = False Then
' They pressed Cancel
MsgBox "Er is geen bestand geselecteerd om te openen!", vbExclamation, "BIS Industrial Services"
Exit Sub 'GoTo exit_openfile
Else
Sheets("Meetstaten").Select
'Clear filter
On Error Resume Next
Sheets("Meetstaten").ShowAllData
Range("A6").Select
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row 'laatste regel bepalen
End With
If LastRow > 5 Then
Range("A6:V" & LastRow).Select
Selection.ClearContents
End If
Range("A6").Select
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'WorkbooknameYMOE = ActiveWorkbook.Name
Workbooks.Open Filename:=Workbookname_ASESR
Workbookname_ASESR = ActiveWorkbook.Name
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
'Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'laatste regel bepalen
End With
'copy Meetstaat, Project, Debiteur
Range("A2:C" & LastRow).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("C6").Select
ActiveSheet.Paste
'Workbooks.Open Filename:=Workbookname_ASESR
'Workbookname_ASESR = ActiveWorkbook.Name
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
'Copy Prio1, prio2, prio3, prio4, prio5
Range("D2:H" & LastRow).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("F6").Select
ActiveSheet.Paste
'copy datum SES montage
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
Range("M2:M" & LastRow).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("K6").Select
ActiveSheet.Paste
'copy datum SES huur, SESnr montage
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
Range("P2:P" & LastRow).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("M6").Select
ActiveSheet.Paste
'copy SESnr Huur
' Windows(Workbookname_ASESR).Activate
' ActiveWindow.WindowState = xlMaximized
' Range("R2:R" & LastRow).Select
' Selection.Copy
'
' Windows(WorkbooknameSISdata).Activate
' Range("N6").Select
' ActiveSheet.Paste
'copy inhuur, uithuur
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
Range("W2:X" & LastRow).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("O6").Select
ActiveSheet.Paste
'copy montage_demontage-bedrag, Huurbedrag
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
Range("AG2:AH" & LastRow).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("Q6").Select
ActiveSheet.Paste
'copy Totaalbedrag, gefact_mon_demon, gefact_huur, gefact_totaal
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
Range("AK2:AN" & LastRow).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("S6").Select
ActiveSheet.Paste
Windows(Workbookname_ASESR).Close savechanges:=False
End If
Call Update_SISdata_ISO
Windows(WorkbooknameSISdata).Activate
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row 'laatste regel bepalen
End With
Range("A5:AM5").Select
Selection.AutoFilter
Range("A5:AM5").Select
Selection.AutoFilter
ActiveSheet.ShowAllData
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C6").End(xlUp).Row 'laatste regel bepalen
End With
ActiveSheet.Range("$A$5:$AM" & LastRow).AutoFilter Field:=25, Criteria1:="<=0", _
Operator:=xlAnd
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C6").End(xlUp).Row 'laatste regel bepalen
End With
With ActiveSheet
Set rngFilt = Application.Intersect(.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible), .Range("A:V"))
End With
rngFilt.Delete
ActiveSheet.ShowAllData
Range("W6:AM6").Select
Selection.AutoFill Destination:=Range("W6:AM1200"), Type:=xlFillDefault
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C6").End(xlUp).Row 'laatste regel bepalen
End With
For Edit_row = 6 To LastRow
Range("A" & Edit_row) = Mid(Range("D" & Edit_row), 34, 10)
If Range("M" & Edit_row) <> "CONFIRMED" Then
Range("B" & Edit_row) = Range("M" & Edit_row)
End If
If Range("K" & Edit_row).Value = " - -" Then
Range("K" & Edit_row) = ""
End If
If Range("L" & Edit_row).Value = " - -" Then
'If IsEmpty(Range("L" & Edit_row).Value) = True Then
Range("L" & Edit_row) = ""
End If
Next Edit_row
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C6").End(xlUp).Row 'laatste regel bepalen
End With
ActiveWorkbook.ActiveSheet.Range("S2") = Application.WorksheetFunction.Subtotal(109, Range("S6:S" & LastRow))
ActiveWorkbook.ActiveSheet.Range("S3") = Application.WorksheetFunction.Subtotal(109, Range("S6:S" & LastRow))
ActiveWorkbook.ActiveSheet.Range("T2") = Application.WorksheetFunction.Subtotal(109, Range("T6:T" & LastRow))
ActiveWorkbook.ActiveSheet.Range("T3") = Application.WorksheetFunction.Subtotal(109, Range("T6:T" & LastRow))
ActiveWorkbook.ActiveSheet.Range("U2") = Application.WorksheetFunction.Subtotal(109, Range("U6:U" & LastRow))
ActiveWorkbook.ActiveSheet.Range("U3") = Application.WorksheetFunction.Subtotal(109, Range("U6:U" & LastRow))
ActiveWorkbook.ActiveSheet.Range("V2") = Application.WorksheetFunction.Subtotal(109, Range("V6:V" & LastRow))
ActiveWorkbook.ActiveSheet.Range("V3") = Application.WorksheetFunction.Subtotal(109, Range("V6:V" & LastRow))
ActiveWorkbook.ActiveSheet.Range("W2") = Application.WorksheetFunction.Subtotal(109, Range("W6:W" & LastRow))
ActiveWorkbook.ActiveSheet.Range("W3") = Application.WorksheetFunction.Subtotal(109, Range("W6:W" & LastRow))
ActiveWorkbook.ActiveSheet.Range("X2") = Application.WorksheetFunction.Subtotal(109, Range("X6:X" & LastRow))
ActiveWorkbook.ActiveSheet.Range("X3") = Application.WorksheetFunction.Subtotal(109, Range("X6:X" & LastRow))
ActiveWorkbook.ActiveSheet.Range("Y2") = Application.WorksheetFunction.Subtotal(109, Range("Y6:Y" & LastRow))
ActiveWorkbook.ActiveSheet.Range("Y3") = Application.WorksheetFunction.Subtotal(109, Range("Y6:Y" & LastRow))
ActiveWorkbook.ActiveSheet.Range("AF2") = Application.WorksheetFunction.Subtotal(109, Range("AF6:AF" & LastRow))
ActiveWorkbook.ActiveSheet.Range("AG2") = Application.WorksheetFunction.Subtotal(109, Range("AG6:AG" & LastRow))
ActiveWorkbook.ActiveSheet.Range("AH2") = Application.WorksheetFunction.Subtotal(109, Range("AH6:AH" & LastRow))
ActiveWorkbook.ActiveSheet.Range("AI2") = Application.WorksheetFunction.Subtotal(109, Range("AI6:AI" & LastRow))
ActiveWorkbook.ActiveSheet.Range("AJ2") = Application.WorksheetFunction.Subtotal(109, Range("AJ6:AJ" & LastRow))
ActiveWorkbook.ActiveSheet.Range("AK2") = Application.WorksheetFunction.Subtotal(109, Range("AK6:AK" & LastRow))
ActiveWorkbook.ActiveSheet.Range("AL2") = Application.WorksheetFunction.Subtotal(109, Range("AL6:AL" & LastRow))
' Verversen draaitabellen
Dim pivC As PivotCache
For Each pivC In ActiveWorkbook.PivotCaches
pivC.Refresh
Next
End Sub
Sub Update_SISdata_ISO()
'
' Update_SISdata Macro
'
Set Workbook = ThisWorkbook
Sheets("Meetstaten").Select
WorkbooknameSISdata = ActiveWorkbook.Name
MsgBox "Selecteer de Isolatiedump om te importeren ", vbMsgBoxSetForeground, "BIS Industrial Services"
Workbookname_ASESR = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Please select a file")
If Workbookname_ASESR = False Then
' They pressed Cancel
MsgBox "Er is geen bestand geselecteerd om te openen!", vbExclamation, "BIS Industrial Services"
Exit Sub 'GoTo exit_openfile
Else
Sheets("Meetstaten").Select
'Clear filter
'Sheets("Meetstaten").ShowAllData
Range("A6").Select
Dim LastRow_STB As Long
With ActiveSheet
LastRow_STB = .Cells(.Rows.Count, "C").End(xlUp).Row 'laatste regel bepalen
End With
' If LastRow_STB > 5 Then
' Range("A6:V" & LastRow).Select
' Selection.ClearContents
' End If
' Range("A6").Select
LastRow_STB = LastRow_STB + 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'WorkbooknameYMOE = ActiveWorkbook.Name
Workbooks.Open Filename:=Workbookname_ASESR
Workbookname_ASESR = ActiveWorkbook.Name
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
Dim LastRow_ISO As Long
With ActiveSheet
LastRow_ISO = .Cells(.Rows.Count, "A").End(xlUp).Row 'laatste regel bepalen
End With
'copy Meetstaat, Project, Debiteur
Range("A2:C" & LastRow_ISO).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("C" & LastRow_STB).Select
ActiveSheet.Paste
'Workbooks.Open Filename:=Workbookname_ASESR
'Workbookname_ASESR = ActiveWorkbook.Name
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
'Copy Prio1, prio2, prio3, prio4, prio5
Range("F2:J" & LastRow_ISO).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("F" & LastRow_STB).Select
ActiveSheet.Paste
'copy datum SES montage
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
Range("AK2:AK" & LastRow_ISO).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("K" & LastRow_STB).Select
ActiveSheet.Paste
'copy datum SES huur blijft LEEG, SESnr montage
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
Range("AM2:AM" & LastRow_ISO).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("M" & LastRow_STB).Select
ActiveSheet.Paste
'copy SESnr Huur blijft LEEG
' Windows(Workbookname_ASESR).Activate
' ActiveWindow.WindowState = xlMaximized
' Range("R2:R" & LastRow).Select
' Selection.Copy
'
' Windows(WorkbooknameSISdata).Activate
' Range("N" & LastRow_STB).Select
' ActiveSheet.Paste
'copy inhuur, uithuur
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
Range("P2:P" & LastRow_ISO).Select
Selection.Copy
' Inhuur
Windows(WorkbooknameSISdata).Activate
Range("O" & LastRow_STB).Select
ActiveSheet.Paste
' Uithuur
Windows(WorkbooknameSISdata).Activate
Range("P" & LastRow_STB).Select
ActiveSheet.Paste
'copy montage_demontage_bedrag, Huurbedrag
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
Range("W2:W" & LastRow_ISO).Select
Selection.Copy
' Montage_demontage_bedrag
Windows(WorkbooknameSISdata).Activate
Range("Q" & LastRow_STB).Select
ActiveSheet.Paste
' Huurbedrag
' Windows(WorkbooknameSISdata).Activate
' Range("R" & LastRow_STB).Select
' ActiveSheet.Paste
'copy Totaalbedrag, gefact_mon_demon, gefact_huur, gefact_totaal
Windows(Workbookname_ASESR).Activate
ActiveWindow.WindowState = xlMaximized
Range("W2:Z" & LastRow_ISO).Select
Selection.Copy
Windows(WorkbooknameSISdata).Activate
Range("S" & LastRow_STB).Select
ActiveSheet.Paste
Windows(Workbookname_ASESR).Close savechanges:=False
End If
End Sub
Try it without using select.
Option Explicit
Sub Update_SISdata_STB()
Dim wb As Workbook, ws As Worksheet
Dim LastRow As Long, Edit_row As Long
Dim rngFilt As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Meetstaten")
With ws
' clear filter
.AutoFilterMode = False
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row 'laatste regel bepalen
If LastRow > 5 Then
.Range("A6:V" & LastRow).ClearContents
End If
Range("A6").Select
End With
Call Import_SISdata_STB
Call Update_SISdata_ISO
With ws
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
' apply filter
.Range("$A$5:$AM" & LastRow).AutoFilter Field:=25, Criteria1:="<=0", Operator:=xlAnd
Set rngFilt = Application.Intersect(.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible), .Range("A:V"))
rngFilt.Delete
.AutoFilterMode = False
.Range("W6:AM6").AutoFill Destination:=.Range("W6:AM1200"), Type:=xlFillDefault
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row 'laatste regel bepalen
For Edit_row = 6 To LastRow
.Range("A" & Edit_row) = Mid(.Range("D" & Edit_row), 34, 10)
If .Range("M" & Edit_row) <> "CONFIRMED" Then
.Range("B" & Edit_row) = .Range("M" & Edit_row)
End If
If .Range("K" & Edit_row).Value = " - -" Then
.Range("K" & Edit_row) = ""
End If
If .Range("L" & Edit_row).Value = " - -" Then
'If IsEmpty(Range("L" & Edit_row).Value) = True Then
.Range("L" & Edit_row) = ""
End If
Next Edit_row
.Range("S2:Y3,AF2:AL2").Formula = "=Subtotal(109,S$6:S$" & LastRow & ")"
End With
' Verversen draaitabellen
Dim pivC As PivotCache
For Each pivC In ActiveWorkbook.PivotCaches
pivC.Refresh
Next
MsgBox "Done"
End Sub
Sub Import_SISdata_STB()
Dim wb As Workbook, wbIn As Workbook
Dim ws As Worksheet, wsIn As Worksheet
Dim FileASESR As Variant, LastRow As Long
'Select the scaffolding dump to import
MsgBox "Selecteer de steigerbouwdump om te importeren ", vbMsgBoxSetForeground, "BIS Industrial Services"
FileASESR = Application.GetOpenFilename( _
FileFilter:="Excel Files (*.xls), *.xls", _
Title:="Please select a file")
If FileASESR = False Then
' They pressed Cancel
MsgBox "Er is geen bestand geselecteerd om te openen!", vbExclamation, "BIS Industrial Services"
Exit Sub 'GoTo exit_openfile
End If
Set wb = ThisWorkbook
Set ws = wb.Sheets("Meetstaten")
Set wbIn = Workbooks.Open(Filename:=FileASESR, ReadOnly:=True)
Set wsIn = wbIn.Sheets(1)
With wsIn
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'copy Meetstaat, Project, Debiteur
'copy Prio1, prio2, prio3, prio4, prio5
.Range("A2:H" & LastRow).Copy ws.Range("C6")
'copy datum SES montage
.Range("M2:M" & LastRow).Copy ws.Range("K6")
'copy datum SES huur, SESnr montage
.Range("P2:P" & LastRow).Copy ws.Range("M6")
'copy inhuur, uithuur
.Range("W2:X" & LastRow).Copy ws.Range("O6")
'copy montage_demontage-bedrag, Huurbedrag
.Range("AG2:AH" & LastRow).Copy ws.Range("Q6")
'copy Totaalbedrag, gefact_mon_demon, gefact_huur, gefact_totaal
.Range("AK2:AN" & LastRow).Copy ws.Range("S6")
End With
MsgBox "Imported " & LastRow - 1 & " rows from " & wsIn.Name, vbInformation, wbIn.Name
wbIn.Close savechanges:=False
End Sub
Sub Update_SISdata_ISO()
' Update_SISdata Macro
Dim wb As Workbook, wbIn As Workbook
Dim ws As Worksheet, wsIn As Worksheet
Dim FileASESR As Variant
Dim LastRow_STB As Long, LastRow_ISO As Long
' Select the Insulation Dump to import
MsgBox "Selecteer de Isolatiedump om te importeren ", vbMsgBoxSetForeground, "BIS Industrial Services"
FileASESR = Application.GetOpenFilename( _
FileFilter:="Excel Files (*.xls), *.xls", _
Title:="Please select a file")
If FileASESR = False Then
' They pressed Cancel
MsgBox "Er is geen bestand geselecteerd om te openen!", vbExclamation, "BIS Industrial Services"
Exit Sub 'GoTo exit_openfile
End If
Set wb = ThisWorkbook
Set ws = wb.Sheets("Meetstaten")
LastRow_STB = 1 + ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Set wbIn = Workbooks.Open(Filename:=FileASESR, ReadOnly:=True)
Set wsIn = wbIn.Sheets(1)
With wsIn
LastRow_ISO = .Cells(.Rows.Count, "A").End(xlUp).Row 'laatste regel bepalen
'copy Meetstaat, Project, Debiteur
.Range("A2:C" & LastRow_ISO).Copy ws.Range("C" & LastRow_STB)
'Copy Prio1, prio2, prio3, prio4, prio5
.Range("F2:J" & LastRow_ISO).Copy ws.Range("F" & LastRow_STB)
'copy datum SES montage
.Range("AK2:AK" & LastRow_ISO).Copy ws.Range("K" & LastRow_STB)
'copy datum SES huur blijft LEEG, SESnr montage
.Range("AM2:AM" & LastRow_ISO).Copy ws.Range("M" & LastRow_STB)
'copy inhuur
.Range("P2:P" & LastRow_ISO).Copy ws.Range("O" & LastRow_STB)
' Uithuur
.Range("P2:P" & LastRow_ISO).Copy ws.Range("P" & LastRow_STB)
'copy montage_demontage_bedrag, Huurbedrag
.Range("W2:W" & LastRow_ISO).Copy ws.Range("Q" & LastRow_STB)
'copy Totaalbedrag, gefact_mon_demon, gefact_huur, gefact_totaal
.Range("W2:Z" & LastRow_ISO).Copy ws.Range("S" & LastRow_STB)
End With
MsgBox "Imported " & LastRow_ISO - 1 & " rows from " & wsIn.Name, vbInformation, wbIn.Name
wbIn.Close savechanges:=False
End Sub
Related
I am updating this post with update code.
Sub ImportWordTable()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo As Integer 'table number in Word
Dim tableStart As Integer
Dim tableTot As Integer
Dim LastRow As Long
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
'On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (.doc; .docx),.doc;.docx", 2, _
"Browse For file containing table To be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '(user cancelled import file browser)
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
'Range("A:AZ").ClearContents
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
tableNo = WordDoc.tables.Count
tableTot = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & " contains no tables", vbExclamation, "Import Word Table"
ElseIf tableNo > 1 Then
tableNo = InputBox(WordDoc.Name & " contains " & tableNo & " tables." & vbCrLf & _
"Enter the table To start from", "Import Word Table", "1")
End If
' Set the header for the Colums
With .tables(tableNo)
Parent.Range("A" & LastRow).Value = .cell(1, 1).Range
Parent.Range("B" & LastRow).Value = .cell(2, 1).Range
Parent.Range("C" & LastRow).Value = .cell(3, 1).Range
Parent.Range("D" & LastRow).Value = .cell(4, 1).Range
Parent.Range("E" & LastRow).Value = .cell(5, 1).Range
Parent.Range("F" & LastRow).Value = .cell(6, 1).Range
Parent.Range("G" & LastRow).Value = .cell(7, 1).Range
Parent.Range("H" & LastRow).Value = .cell(8, 1).Range
Parent.Range("I" & LastRow).Value = .cell(9, 1).Range
Parent.Range("J" & LastRow).Value = .cell(10, 1).Range
Parent.Range("K" & LastRow).Value = .cell(11, 1).Range
Parent.Range("L" & LastRow).Value = .cell(12, 1).Range
Parent.Range("M" & LastRow).Value = .cell(13, 1).Range
Parent.Range("N" & LastRow).Value = .cell(14, 1).Range
Parent.Range("O" & LastRow).Value = .cell(15, 1).Range
Parent.Range("P" & LastRow).Value = .cell(16, 1).Range
Parent.Range("Q" & LastRow).Value = .cell(17, 1).Range
Parent.Range("R" & LastRow).Value = .cell(18, 1).Range
Parent.Range("S" & LastRow).Value = .cell(19, 1).Range
Parent.Range("T" & LastRow).Value = .cell(20, 1).Range
Parent.Range("U" & LastRow).Value = .cell(21, 1).Range
Parent.Range("V" & LastRow).Value = .cell(22, 1).Range
Parent.Range("W" & LastRow).Value = .cell(23, 1).Range
Parent.Range("X" & LastRow).Value = .cell(24, 1).Range
Parent.Range("Y" & LastRow).Value = .cell(25, 1).Range
End With
LastRow = LastRow + 1
' Get the date from the tables
For tableStart = tableNo To tableTot
With .tables(tableStart)
.cell(1, 2).Range.Copy
With Range("A" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(2, 2).Range.Copy
With Range("B" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(3, 2).Range.Copy
With Range("C" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(4, 2).Range.Copy
With Range("D" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(5, 2).Range.Copy
With Range("E" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(6, 2).Range.Copy
With Range("F" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(7, 2).Range.Copy
With Range("G" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(8, 2).Range.Copy
With Range("H" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(9, 2).Range.Copy
With Range("I" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(10, 2).Range.Copy
With Range("J" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(11, 2).Range.Copy
With Range("K" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(12, 2).Range.Copy
With Range("L" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(13, 2).Range.Copy
With Range("M" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(14, 2).Range.Copy
With Range("N" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(15, 2).Range.Copy
With Range("O" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(16, 2).Range.Copy
With Range("P" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(17, 2).Range.Copy
With Range("Q" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(18, 2).Range.Copy
With Range("R" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(19, 2).Range.Copy
With Range("S" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(20, 2).Range.Copy
With Range("T" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(21, 2).Range.Copy
With Range("U" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(22, 2).Range.Copy
With Range("V" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(23, 2).Range.Copy
With Range("W" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(24, 2).Range.Copy
With Range("X" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.cell(25, 2).Range.Copy
With Range("Y" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
End With
LastRow = LastRow + 1
Next tableStart
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
It is working but having only one issue. if a cell is having multiple paragraph then it's getting pasted in multiple row of excel. I want like if 2nd column of 1st row of word file is having 3 paragraph, then in excel as well all these 3 paragraph should get pasted in same column.
Word Input
Excel File Output
Hope I am able to explain it properly.
I have amended your script to produce the desired results.
The clear contents and targeting is removed as this will allow other word tables to be added to the same sheet, amend the script if you want to clear the sheet each time.
The table start selection now works by setting the tableNo as the start of the loop
It pulls the heading from the first column of the first selected tableNo
VBA Script:
Sub ImportWordTable()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo As Integer 'table number in Word
Dim tableStart As Integer
Dim tableTot As Integer
Dim LastRow As Long
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
'On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse For file containing table To be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '(user cancelled import file browser)
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
'Range("A:AZ").ClearContents
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
tableNo = WordDoc.tables.Count
tableTot = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & " contains no tables", vbExclamation, "Import Word Table"
ElseIf tableNo > 1 Then
tableNo = InputBox(WordDoc.Name & " contains " & tableNo & " tables." & vbCrLf & _
"Enter the table To start from", "Import Word Table", "1")
End If
' Set the header for the Colums
With .tables(tableNo)
Parent.Range("A" & LastRow).Value = .Cell(1, 1).Range
Parent.Range("B" & LastRow).Value = .Cell(2, 1).Range
Parent.Range("C" & LastRow).Value = .Cell(3, 1).Range
End With
LastRow = LastRow + 1
' Get the date from the tables
For tableStart = tableNo To tableTot
With .tables(tableStart)
.Cell(1, 2).Range.Copy
With Range("A" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.Cell(2, 2).Range.Copy
With Range("B" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
.Cell(3, 2).Range.Copy
With Range("C" & LastRow)
.Select
.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
.Borders.LineStyle = xlLineStyleNone
End With
End With
LastRow = LastRow + 1
Next tableStart
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
As I said in my above comment, one Word table column cannot copy directly, not having a range property. Two ways are recommended, to avoid copying of each table cell, which consumes Excel resources and is very slow. One way would be to select the respective column (VBA allows it) and copy/paste selection. But using clipboard it is slow for more involved documents.
The most efficient way is to place the column range in an array (working only in memory) and drop its content, at once, in the necessary range. Then, try to format it. Copying the format from Word is also slow and consumes resources. I used a trick: Transforming the dropped array content range in an listObject, then UnList it. To benefit of the standard table format. If you need them to be tables, you have to comment the code line tbl.UnList:
Sub ImportWordTable()
Dim WordApp As Object, WordDoc As Object, ws As Worksheet
Dim arrFileList As Variant, FileName As Variant, tableNo As Integer
Dim tableStart As Integer, tableTot As Integer, Target As Range
Set ws = ActiveSheet 'it is good to fully qualify all the objects
'so, use here the sheet you need
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '(user cancelled import file browser)
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
ws.Range("A:A").Clear 'clear its format, too...
Set Target = ws.Range("A1")
Dim i As Long, tbl As ListObject
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
tableNo = WordDoc.tables.count
tableTot = WordDoc.tables.count
If tableNo = 0 Then
MsgBox WordDoc.name & " contains no tables", vbExclamation, "Import Word Table"
ElseIf tableNo > 1 Then
tableNo = InputBox(WordDoc.name & " contains " & tableNo & " tables." & vbCrLf & _
"Enter the table to start from", "Import Word Table", "1")
End If
For tableStart = tableNo To tableTot 'start iteration from `tableNo` if not the default...
Dim arr: ReDim arr(1 To .tables(tableStart).rows.count, 1 To 1) 'declare and ReDim the necessary aray
With .tables(tableStart)
For i = 1 To .rows.count 'load the array with the second column content
arr(i, 1) = .Range.Columns(2).cells(i)
arr(i, 1) = left(arr(i, 1), Len(arr(i, 1)) - 1) 'eliminate the Word strange ending line character
Next i
With Target.Resize(.rows.count, 1)
.Value = arr
Set tbl = ws.ListObjects.Add(xlSrcRange, ws.Range(.address), , xlYes) 'make the range a table
tbl.Unlist 'just transforming the table in range, but keeping its format...
End With
Set Target = Target.Offset(.Rows.Count + 2) 'reset Target
End With
Next tableStart
.Close False 'close the open document, without saving it
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing: Set WordApp = Nothing
End Sub
I can run this program one iteration at a time, but when I let it run on the next i, the VarCellValues come back as values from a different sheet. What would be causing the active sheet to change away from the workbook and first sheet the macro is opened from?
Sub copy_financials_2022()
'
' copy_financials_2022 Macro
'
Dim i As Integer
Dim VarCellValue As String
Dim VarCellValue2 As String
Dim VarCellValue3 As String
Dim VarCellValue4 As String
Dim VarCellValue5 As String
Dim currwbk As Workbook
Set currwbk = ThisWorkbook
For i = Range("A2").Value To Range("C2").Value
Set currwbk = ThisWorkbook
VarCellValue = Range("B" & i).Value
VarCellValue2 = Range("C" & i).Value
VarCellValue3 = Range("A" & i).Value
VarCellValue4 = Range("D" & i).Value
VarCellValue5 = Range("E" & i).Value
Application.DisplayAlerts = False
Workbooks.Open (Range("A3").Value & VarCellValue4 & ".xlsx")
'Workbooks.Open ("S:\Finance\_2022 FINANCIAL REPORTS\National Financials\09-30\CONSOLIDATED MONTHLY FINANCIAL STATEMENT" & ".xlsm")
'Workbooks.Open (Range("B3").Value & VarCellValue4)
Workbooks(VarCellValue4).Activate
'inserted "Sheets(VarCellValue5).Activate" below after the third tab was active on Los Angeles Sheet (should have been the first tab)
Sheets(VarCellValue5).Activate
Sheets(VarCellValue5).Unprotect Password:="forecast22"
Columns("A:S").Select
Selection.EntireColumn.Hidden = False
Workbooks.Open ("S:\Finance\_2022 FINANCIAL REPORTS\National Financials\09-30\CONSOLIDATED MONTHLY FINANCIAL STATEMENT" & ".xlsm")
Sheets(VarCellValue2).Activate
Range("A6:Q6").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range("A6:Q88").Select
Selection.Copy
Workbooks(VarCellValue4).Activate
Range("A6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B:B,D:E,G:G,I:J,L:N,K:K").Select
Range("K1").Activate
Selection.EntireColumn.Hidden = True
Range("C7").Select
'Range("A6").Select
Application.CutCopyMode = False
ActiveWorkbook.Save
Range("C7").Select
ActiveCell.FormulaR1C1 = "Sept MTD"
Range("H7").Select
ActiveCell.FormulaR1C1 = "Sept YTD"
Range("S8").Select
ActiveCell.FormulaR1C1 = "Aug - Dec 2021"
Range("A6").Select
ActiveSheet.Protect Password:="forecast22"
ActiveWorkbook.Save
ActiveWindow.Close
'Workbooks.Close ("S:\Finance\_2022 FINANCIAL REPORTS\National Financials\05-31\CONSOLIDATED MONTHLY FINANCIAL STATEMENT" & ".xlsm")
Next i
End Sub
Instead of relying on a sheet being active, fully qualify each Range call with the appropriate workbook/worksheet.
Dim currwbk As Workbook
Set currwbk = ThisWorkbook
Dim currWs As Worksheet
Set currWs = currwbk.ActiveSheet
For i = currWs.Range("A2").Value To currWs.Range("C2").Value
VarCellValue = currWs.Range("B" & i).Value
VarCellValue2 = currWs.Range("C" & i).Value
VarCellValue3 = currWs.Range("A" & i).Value
VarCellValue4 = currWs.Range("D" & i).Value
VarCellValue5 = currWs.Range("E" & i).Value
Dim wb As Workbook
Set wb = Workbooks.Open(currWs.Range("A3").Value & VarCellValue4 & ".xlsx")
With wb.Worksheets(VarCellValue5)
.Unprotect Password:="forecast22"
.Columns("A:S").Hidden = False
' and so on
End With
Next
Good morning,
I tried with ActiveCell.PasteSpecial Paste:=xlPasteValuesbut it doesnt work.
Sub CopyCoverage()
Dim x As Worksheet, y As Worksheet, LastRow
Set x = Sheets("1SalesAnalysis")
Set y = Sheets("Basics")
LastRow = x.Cells.SpecialCells(xlCellTypeLastCell).Row
x.Range("A2:A" & LastRow).Copy y.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
x.Range("B2:B" & LastRow).Copy y.Cells(Rows.Count, "F").End(xlUp).Offset(1, 0)
x.Range("C2:C" & LastRow).Copy y.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)
x.Range("D2:D" & LastRow).Copy y.Cells(Rows.Count, "L").End(xlUp).Offset(1, 0)
x.Range("E2:E" & LastRow).Copy y.Cells(Rows.Count, "M").End(xlUp).Offset(1, 0)
x.Range("F2:F" & LastRow).Copy y.Cells(Rows.Count, "P").End(xlUp).Offset(1, 0)
x.Range("G2:G" & LastRow).Copy y.Cells(Rows.Count, "Q").End(xlUp).Offset(1, 0)
x.Range("H2:H" & LastRow).Copy y.Cells(Rows.Count, "R").End(xlUp).Offset(1, 0)
x.Range("I2:I" & LastRow).Copy y.Cells(Rows.Count, "S").End(xlUp).Offset(1, 0)
x.Range("J2:J" & LastRow).Copy y.Cells(Rows.Count, "T").End(xlUp).Offset(1, 0)
x.Range("K2:K" & LastRow).Copy y.Cells(Rows.Count, "V").End(xlUp).Offset(1, 0)
x.Range("L2:L" & LastRow).Copy y.Cells(Rows.Count, "W").End(xlUp).Offset(1, 0)
x.Range("O2:O" & LastRow).Copy y.Cells(Rows.Count, "EA").End(xlUp).Offset(1, 0)
x.Range("P2:P" & LastRow).Copy y.Cells(Rows.Count, "EI").End(xlUp).Offset(1, 0)
x.Range("Q2:Q" & LastRow).Copy y.Cells(Rows.Count, "EB").End(xlUp).Offset(1, 0)
x.Range("R2:R" & LastRow).Copy y.Cells(Rows.Count, "EJ").End(xlUp).Offset(1, 0)
x.Range("S2:S" & LastRow).Copy y.Cells(Rows.Count, "EC").End(xlUp).Offset(1, 0)
x.Range("T2:T" & LastRow).Copy y.Cells(Rows.Count, "EK").End(xlUp).Offset(1, 0)
ActiveCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
Thanks
Best regards
Store the mapping rules in an array so you can reuse the same code for each column.
Option Explicit
Sub CopyCoverage()
Dim wsX As Worksheet, wsY As Worksheet
Dim LastRowX As Long, msg As String
Dim rngX As Range, rngY As Range
Set wsX = Sheets("1SalesAnalysis")
Set wsY = Sheets("Basics")
LastRowX = wsX.Cells.SpecialCells(xlCellTypeLastCell).Row
Dim map, ar, i As Integer
map = Split("A=>E,B=>F,C=>G,D=>L,E=>M,F=>P,G=>Q,H=>R,I=>S,J=>T,K=>V,L=>W," & _
"O=>EA,P=>EI,Q=>EB,R=>EJ,S=>EC,T=>EK", ",")
Application.ScreenUpdating = False
For i = 0 To UBound(map)
ar = Split(map(i), "=>")
msg = msg & vbLf & ar(0) & " to " & ar(1)
Set rngX = wsX.Range(ar(0) & "2:" & ar(0) & LastRowX)
Set rngY = wsY.Cells(Rows.Count, ar(1)).End(xlUp).Offset(1, 0)
rngY.Resize(rngX.Rows.Count).Value2 = rngX.Value2
Next
Application.ScreenUpdating = True
MsgBox "Copied " & msg, vbInformation
End Sub
The best way to avoid formatting not being copied/pasted is by not copying/pasting in the first place: you can simply do:
Destination_Range.Value = Source_Range.Value
Like this, only the value gets copied", but the formatting is not involved.
More information can be found in this reference question about this subject.
Those one-line 'copy-pastes' already finishes the task of copy-paste, so the ActiveCell.PasteSpecial at the bottom part of your code doesn't do anything.
There are several ways to do it but I will stick to the pattern of your code:
Sub CopyCoverage()
Dim x As Worksheet
Dim y As Worksheet
Dim LastRow As Long
Set x = ThisWorkbook.Sheets("Sheet2")
Set y = ThisWorkbook.Sheets("Ans")
LastRow = x.Cells.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False '~turn off the 'animation' to speed up a bit
'The logic will be, copy-paste, copy-paste
x.Range("A2:A" & LastRow).Copy
y.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
x.Range("B2:B" & LastRow).Copy
y.Cells(Rows.Count, "F").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
'and so and so forth
'Just continue with this pattern
Application.CutCopyMode = False '~end line
Application.ScreenUpdating = True '~turn on the 'animation' again
End Sub
I have a Userform with the following code attached to the "OK" button. All the code works fine other than the last 4 lines. Full code associated to OK button shown below, code not working is:
Dim SheetName As String
SheetName = ActiveSheet.Name
Call SheetCleanup
Worksheets(SheetName).Activate
It is as if it completely ignores it. SheetCleanup is located in a Module, and my suspicions are that there is an issue going from a Userform to a Module? But I am unfamiliar with this.
Full code is here:
Private Sub CommandButtonOK_Click()
If ComboBoxTargetEvent.Value = "" Or ComboBoxDesigner.Value = "" Or ComboBoxSignoff.Value = "" Or ComboBoxCarArea.Value = "" Or ComboBoxOriginator.Value = "" Or TextBoxNumberOfJobs.Value = "" Or ComboBoxProjectTitle.Value = "" Then _
MsgBox "You must complete all fields", vbInformation
Else:
'Go to worksheet based on Car Area
Dim CarArea As String
CarArea = ComboBoxCarArea.Value
Worksheets(CarArea).Activate
'Enter Target Event Into Column A
Columns("A").Find("", Cells(Rows.Count, "A")).Value = ComboBoxTargetEvent.Value
'Enter Project Title into column B
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 1).Value = ComboBoxProjectTitle.Value
'Enter Designer name into column E
If _
ComboBoxDesigner.Value <> "Various" Then _
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 4).Value = ComboBoxDesigner.Value
'Enter Sign-off name into column F
If _
ComboBoxSignoff.Value <> "Various" Then _
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 5).Value = ComboBoxSignoff.Value
'Enter Originator name into column F
If _
ComboBoxOriginator.Value <> "Various" Then _
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 3).Value = ComboBoxOriginator.Value
'Enter Data Formula into columns H & I
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 7).Select
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 7).Copy
Selection.Offset(1, 0).PasteSpecial Paste:=xlPasteFormulas
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 8).Select
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 8).Copy
Selection.Offset(1, 0).PasteSpecial Paste:=xlPasteFormulas
'Enter temp values into C & G
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 2).Value = "ENTER DESCRIPTION HERE (CAPS LOCK ONLY)"
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 6).Value = "ENTER DATE"
'Enter "N" into Job Completed
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 9).Value = "N"
'Enter Data Validation List for Target Event
Dim ws As Worksheet
Dim NumberOfJobs As Long
Dim LastUsedInAA As Long
Dim range9 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range9 = ws.Range("a:a")
LastUsedInAA = Range("A" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("A" & LastUsedInAA).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete 'delete previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range9.Address
End With
End If
'Enter Data Validation List for Designer
Dim LastUsedInE As Long
Dim range1 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range1 = ws.Range("c:c")
LastUsedInE = Range("E" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("E" & LastUsedInE).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete 'delete previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range1.Address
End With
End If
'Enter Data Validation List for Senior Designer
Dim LastUsedInF As Long
Dim range2 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range2 = ws.Range("b:b")
LastUsedInF = Range("F" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("F" & LastUsedInF).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range2.Address
End With
End If
'Enter Data Validation List for Originator
Dim LastUsedInD As Long
Dim range5 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range5 = ws.Range("f:f")
LastUsedInD = Range("D" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("d" & LastUsedInD).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range5.Address
End With
End If
'Enter Data Validation List for Job Completed
Dim LastUsedInJ As Long
Dim range3 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range3 = ws.Range("d:d")
LastUsedInJ = Range("J" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("J" & LastUsedInJ).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete 'delete previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range3.Address
End With
End If
'Multiply rows for multiple jobs
Dim LastUsedInA As Long
LastUsedInA = Range("A" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 1 Then
Range("A" & LastUsedInA).Select
Selection.Resize(Selection.Rows.Count, _
Selection.Columns.Count + 10).Copy
Range("A" & LastUsedInA + 1).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 2, _
Selection.Columns.Count).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormulas
End If
'Clear the clipboard
Application.CutCopyMode = False
'select last cell in A
Range("A" & LastUsedInA).Select
'Clear all fields before hide
ComboBoxTargetEvent.Value = ""
ComboBoxDesigner.Value = ""
ComboBoxSignoff.Value = ""
ComboBoxCarArea.Value = ""
ComboBoxOriginator.Value = ""
TextBoxNumberOfJobs.Value = ""
ComboBoxProjectTitle.Value = ""
'Hide Window
CreateJobs.Hide
End If
Dim SheetName As String
SheetName = ActiveSheet.Name
Call SheetCleanup
Worksheets(SheetName).Activate
End Sub
Code for SheetCleanup is as follows:
Public Sub SheetCleanup()
'Clan-up on Car Area WorkSheets
Application.ScreenUpdating = False
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
Select Case sh.Name
Case Is = "Contents Page", "Completed", "VBA_Data", "Front Team Project List", "Mid Team Project List", "Rear Team Project List", "Acronyms"
Case Else
With sh
'set zoom
sh.Activate
ActiveWindow.Zoom = 100
'format columns and rows
.Columns("g:g").NumberFormat = "dd-mm"
.Columns("i:i").NumberFormat = "0"
.Columns("A").ColumnWidth = 27
.Columns("B").ColumnWidth = 50
.Columns("C").ColumnWidth = 50
.Columns("D").ColumnWidth = 21
.Columns("E").ColumnWidth = 27
.Columns("F").ColumnWidth = 21
.Columns("G").ColumnWidth = 10
.Columns("H").ColumnWidth = 15
.Columns("I").ColumnWidth = 22
.Columns("J").ColumnWidth = 17
.Rows("1").RowHeight = 77.2
.Rows("2").RowHeight = 10
.Rows("3").RowHeight = 30
.Rows("4").RowHeight = 10
.Rows("5").RowHeight = 18
.Columns("a:j").HorizontalAlignment = xlCenter
.Columns("b:c").HorizontalAlignment = xlLeft
.Rows("3").HorizontalAlignment = xlCenter
.Rows("5").HorizontalAlignment = xlCenter
.Range("A:J").Validation.Delete
'set data validation for Target Event
Dim ws As Worksheet
Dim wsVBA As Worksheet
Dim range1 As Range, rng As Range
Dim LastRowTargetEvent As Long
Set wsVBA = ThisWorkbook.Worksheets("VBA_Data")
LastRowTargetEvent = wsVBA.Cells(.Rows.Count, "A").End(xlUp).Row
Set range1 = wsVBA.Range("A2:A" & LastRowTargetEvent)
Set ws = ActiveSheet
Set rng = ws.Range("a6:a1000")
With rng.Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & wsVBA.Name & "'!" & range1.Address
End With
End With
End Select
Next sh
End Sub
Our company has 36 departments and we use a master budgeting worksheet to develop the budget. The department numbers are not sequential and their budgets are all different. I put together the following macro to send the worksheets to the individual departments. The master is full of VLOOKUPs and other formulae, but the individual departments receive only the final results and a couple of columns for their changes. They can make changes to any number that is not highlighted in yellow. The macro works perfectly for only one department, but when I tried to copy it 35 times below itself so that I could send a worksheet to all departments, I received an error message that said my procedure was too large. I divided it in half and I still received the message!
Sub Macro1()
'
' Macro1 Macro
'' Prepares O&M budget Worksheet for uploading
' Dim sourceSheet as Worksheet
Workbooks.Open Filename:="F:\Rick\2020 Budget\2020 O&M Budget.xlsx"
Set sourcesheet = Worksheets("Dept Detail-O&M Book")
sourcesheet.Activate
' Dim N As Long
' Dim T As Long
' Dim LastRow As Long
lastrow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
Dim i As Long, Total As Long
Dim cell As Range
Application.EnableEvents = False
'
Application.Goto Reference:="Dept_01"
Selection.Copy
Workbooks.Open Filename:="Q:\O&M\Departmental Budgets\Dept 1 MOEC.xlsx"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ThisWorkbook.Activate
Application.CutCopyMode = False
Selection.Copy
Windows("Dept 1 MOEC.xlsx").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("R1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Application.CutCopyMode = False
n = Cells(Rows.Count, "R").End(xlUp).Row
Cells(n, "R").Formula = "=SUM(R1:R" & n - 1 & ")"
activecell.Select
Selection.Copy
activecell.Offset(0, 2).Select
ActiveSheet.Paste
Selection.Copy
activecell.Offset(0, 2).Select
ActiveSheet.Paste
Range("X9").Select
activecell.FormulaR1C1 = "=iferror(+RC[-2]/RC[-10],0)"
Range("X9").Select
T = Cells(Rows.Count, "X").End(xlUp).Row
Selection.AutoFill Destination:=Range("x9:x" & T)
With ActiveSheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
For i = lastrow To 1 Step -1
If Range("B" & i).Value = "1010" Or _
Range("B" & i).Value = "1020" Or _
Range("B" & i).Value = "2172" Or _
Range("B" & i).Value = "2190" Or _
Range("B" & i).Value = "2200" Or _
Range("B" & i).Value = "2290" Or _
Range("B" & i).Value = "4020" Or _
Range("B" & i).Value = "4050" Or _
Range("B" & i).Value = "4060" Or _
Range("B" & i).Value = "4070" Or _
Range("B" & i).Value = "4090" Or _
Range("B" & i).Value = "4100" Or _
Range("B" & i).Value = "4110" Or _
Range("B" & i).Value = "4509" Or _
Range("B" & i).Value = "4510" Or _
Range("B" & i).Value = "4600" Or _
Range("B" & i).Value = "4610" Or _
Range("B" & i).Value = "4700" Or _
Range("B" & i).Value = "5710" Or _
Range("B" & i).Value = "5721" Or _
Range("B" & i).Value = "5723" Or _
Range("B" & i).Value = "5725" Or _
Range("B" & i).Value = "5729" Or _
Range("B" & i).Value = "5730" Or _
Range("B" & i).Value = "5731" Then
.Range("R" & i).Interior.Color = RGB(255, 255, 0)
.Range("T" & i).Interior.Color = RGB(255, 255, 0)
End If
Next i
Application.EnableEvents = True
End With
With ActiveSheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
For i = lastrow To 1 Step -1
If Range("B" & i).Value = "5721" Or _
Range("B" & i).Value = "9000" Or _
Range("B" & i).Value = "9005" Or _
Range("B" & i).Value = "9010" Or _
Range("B" & i).Value = "9030" Then
.Range("R" & i).Interior.Color = RGB(255, 255, 0)
.Range("T" & i).Interior.Color = RGB(255, 255, 0)
End If
Next i
Application.EnableEvents = True
End With
Range("A1").Select
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
Could someone offer suggestions on how to reduce the size of the macro and/or make it more efficient? Thanks!
I took a shot at cleaning this up (at least to make it run, for now) - I don't know enough about what you're doing to clean up that mid section, though. The problem undoubtedly was that long If statement.
Instead of all the Ors, put all your values in an array then test against that array with IsError:
Option Explicit
Sub Macro1()
Dim valuearr As Variant
Dim cell As Range
Dim sourcesheet As Worksheet
Dim lastrow As Long, i As Long, n As Long
Workbooks.Open Filename:="F:\Rick\2020 Budget\2020 O&M Budget.xlsx"
Set sourcesheet = Worksheets("Dept Detail-O&M Book")
sourcesheet.Activate
lastrow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
'This section needs to be cleaned up...
Application.Goto Reference:="Dept_01"
Selection.Copy
Workbooks.Open Filename:="Q:\O&M\Departmental Budgets\Dept 1 MOEC.xlsx"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ThisWorkbook.Activate
Application.CutCopyMode = False
Selection.Copy
Windows("Dept 1 MOEC.xlsx").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("R1").Select
Selection.End(xlDown).Select
Application.CutCopyMode = False
n = Cells(Rows.Count, "R").End(xlUp).Row
Cells(n, "R").Formula = "=SUM(R1:R" & n - 1 & ")"
ActiveCell.Copy
ActiveCell.Offset(0, 2).Paste
Selection.Offset(0, 2).Select
ActiveSheet.Paste
Range("X9").FormulaR1C1 = "=iferror(+RC[-2]/RC[-10],0)"
Range("X9").AutoFill Destination:=Range("x9:x" & Cells(Rows.Count, "X").End(xlUp).Row)
With ActiveSheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
valuearr = Array(1010, 1020, 2172, 2190, 2200, 2290, 4020, 4050, 4060, 4070, 4090, 4100, 4110, 4509, 4510, 4600, 4610, 4700, 5710, 5721, 5723, 5725, 5729, 5730, 5731, 9000, 9005, 9010, 9030)
For i = lastrow To 1 Step -1
If IsError(Application.Match(Range("B" & i).Value, valuearr, 0)) Then
.Range("R" & i).Interior.Color = RGB(255, 255, 0)
.Range("T" & i).Interior.Color = RGB(255, 255, 0)
End If
Next i
End With
Application.EnableEvents = True
ActiveWorkbook.Save
ActiveWindow.Close
End Sub