so i started writting a code that would write from Workbook1 UserForm to WorkBook2 sheet. For some unknown reason it's not copying the data .
Private Sub CommandButton1_Click()
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim src As Workbook
' Open EXCEL
Set src = Workbooks.Open("U:\Mecânica\Produção\63177 - Qualidade\Rejeição Interna\Dados\Gaspar\Projeto Manutenção.xlsm", True, False)
WS_Count = src.Worksheets.Count
For o = 1 To WS_Count
src.Worksheets(o).Unprotect password:="projmanutencao"
Next o
last = src.Worksheets(Manutencao).Range("A65536").End(xlUp).Row
' Write regists
src.Worksheets(Manutencao).Cells(last + 1, 1) = Now() 'data
src.Worksheets(Manutencao).Cells(last + 1, 2) = manutencaoexp.ComboBox3 'nº equipamento
src.Worksheets(Manutencao).Cells(last + 1, 3) = manutencaoexp.ComboBox5 'avaria
src.Worksheets(Manutencao).Cells(last + 1, 4) = manutencaoexp.ComboBox4 'serviços
' src.Worksheets(Manutencao).Cells(last + 1, 5) = Velocidade 'produtos
' src.Worksheets(Manutencao).Cells(last + 1, 6) = Qualidade 'duração
' src.Worksheets(Manutencao).Cells(last + 1, 7) = Data 'operario
src.Worksheets(Manutencao).Cells(last + 1, 8) = manutencaoexp.ComboBox6 'tipo de manutenção
For o = 1 To WS_Count
src.Worksheets(o).Protect password:="projmanutencao"
Next o
Application.DisplayAlerts = False 'IT WORKS TO DISABLE ALERT PROMPT
'SAVES FILE USING THE VARIABLE BOOKNAME AS FILENAME
src.Save
Application.DisplayAlerts = True 'RESETS DISPLAY ALERTS
' CLOSE THE SOURCE FILE.
src.Close True ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
If someone can help fix this piece of code , or maybe have a code that copies from a diferente workbook userform . I'm getting a subscript out of range error in
last = src.Worksheets(Manutenção).Range("A65536").End(x1Up).Row
Assuming 'Manutencao' is the worksheet name, then change this line to:
last = src.Worksheets("Manutencao").Range("A65536").End(xlUp).Row
Note the "" around the worksheet name. You'll have to change this wherever you reference this worksheet.
EDIT: Your code could be rewritten like this, to be a little clearer;
Private Sub CommandButton1_Click()
Dim src As Workbook
Dim last As Long
On Error GoTo ErrHandler
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set src = Workbooks.Open("U:\Mecânica\Produção\63177 - Qualidade\Rejeição Interna\Dados\Gaspar\Projeto Manutenção.xlsm", True, False)
With src.Worksheets("Manutencao")
.Unprotect Password:="projmanutencao"
last = .Cells(Rows.Count, "A").End(xlUp).Row
.Cells(last + 1, 1) = Now() 'data
.Cells(last + 1, 2) = manutencaoexp.ComboBox3 'nº equipamento
.Cells(last + 1, 3) = manutencaoexp.ComboBox5 'avaria
.Cells(last + 1, 4) = manutencaoexp.ComboBox4 'serviços
' .Cells(last + 1, 5) = Velocidade 'produtos
' .Cells(last + 1, 6) = Qualidade 'duração
' .Cells(last + 1, 7) = Data 'operario
.Cells(last + 1, 8) = manutencaoexp.ComboBox6 'tipo de manutenção
.Protect Password:="projmanutencao"
End With
src.Close True ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
ErrHandler:
If Err Then
Debug.Print "Error", Err.Number, Err.Description
Err.Clear
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Related
I have below code.
In first loop the excel file is extracted from the SAP - loop with variable a.
In the second loop (loop with variable k) the invoice is extracted from SAP (takes the order number from earlier extracted excel file).
The number of the order is taken from the excel file and paste to order in SAP.
Sometimes it happens, that order is either not taken from excel or not paste in SAP and the field for the order is empty.
This situation try to generates all the orders for the Controlling Area, which is very time-consuming (in fact it lasts hours).
I tried to add this line of code before the paste to the order, but of no result
Application.Wait Now + TimeValue("0:00:05")
Have you met this in your coding and could help with this?
extracting the excel file from SAP
Sub invoice_extr()
'##########################
'zapisuje pliki xlsx ordery
'##########################
Application.ScreenUpdating = False
SheetSrc = "Input data"
On Error Resume Next
If Not IsObject(SAPApplication) Then
Set SapGuiAuto = GetObject("SAPGUI")
If Err.Number <> 0 Then Exit Sub
Set SAPApplication = SapGuiAuto.GetScriptingEngine
If Err.Number <> 0 Then Exit Sub
End If
If Not IsObject(Connection) Then
Set Connection = SAPApplication.Children(0)
If Err.Number <> 0 Then
MsgBox ("Please, open SAP!")
Exit Sub
Else
End If
End If
If Not IsObject(session) Then
Set session = Connection.Children(0)
End If
On Error GoTo 0
Application.Wait (Now + TimeValue("0:00:01") / 1.5)
Dim a As Double
Dim last_row As Double
last_row = Cells(Rows.Count, 1).End(xlUp).Row
Range("b2:c" & last_row).Select
Selection.ClearContents
Dim path As String
path = Cells(2, 6)
For a = 2 To last_row
'###########################################################
'####SPRAWDZA CZY JEST JUZ PLIK XLSX O TAKIEJ NAZWIE########
'###########################################################
Dim objFSO_november1 As Object
Dim objFolder_november1 As Object
Dim objFile_november1 As Object
Dim objFile1_november1 As Object
Dim aa_november1 As Integer
Dim bb_november1 As Integer
Set objFSO_november1 = CreateObject("Scripting.FileSystemObject")
Set objFolder_november1 = objFSO_november1.GetFolder(path)
bb_november1 = 0
For Each objFile1_november1 In objFolder_november1.Files
bb_november1 = bb_november1 + 1
Next objFile1_november1
Dim myArray_november1() As Variant
ReDim Preserve myArray_november1(bb_november1, 1)
aa_november1 = 0
For Each objFile_november1 In objFolder_november1.Files
myArray_november1(aa_november1, 1) = objFile_november1.name
aa_november1 = aa_november1 + 1
Next objFile_november1
Dim aa As Double
Dim zz As Double
zz = 0
For aa = 0 To aa_november1 - 1
Dim how_many As Double
how_many = Len(Cells(a, 1))
'MsgBox (Cells(a, 1))
'MsgBox (Left(myArray_november1(aa, 1), how_many))
'MsgBox (aa)
If (Cells(a, 1) * 1) = (Left(myArray_november1(aa, 1), how_many) * 1) Then
Cells(a, 2) = "Done"
zz = zz + 1
'MsgBox (zz)
End If
If zz <> 0 Then
GoTo line1
End If
Next aa
Erase myArray_november1
If zz <> 0 Then
GoTo line1
End If
session.findById("wnd[0]").maximize
session.findById("wnd[0]/tbar[0]/okcd").Text = "/Ns_alr_87013019"
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]/usr/txt$6-KOKRS").Text = Cells(a, 4)
Workbooks("Saving_invoice.xlsm").Activate
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").Text = Cells(a, 1)
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").SetFocus
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").caretPosition = 6
session.findById("wnd[0]/tbar[1]/btn[8]").press
'On Error GoTo line1
On Error Resume Next
session.findById("wnd[0]/shellcont/shell/shellcont[2]/shell").hierarchyHeaderWidth = 453
session.findById("wnd[0]/usr/lbl[62,8]").SetFocus
session.findById("wnd[0]/usr/lbl[62,8]").caretPosition = 9
session.findById("wnd[0]").sendVKey 2
session.findById("wnd[1]/usr/lbl[1,2]").SetFocus
session.findById("wnd[1]/usr/lbl[1,2]").caretPosition = 4
session.findById("wnd[1]").sendVKey 2
'################################################################
'#############WYBIERA LAYOUT /MACRO##############################
'################################################################
session.findById("wnd[0]/tbar[1]/btn[33]").press
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").currentCellRow = -1
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectColumn "VARIANT"
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").contextMenu
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectContextMenuItem "&FILTER"
session.findById("wnd[2]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").Text = "/MACRO"
session.findById("wnd[2]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").caretPosition = 6
session.findById("wnd[2]/tbar[0]/btn[0]").press
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectedRows = "0"
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").clickCurrentCell
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").currentCellColumn = "BELNR"
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectedRows = "0"
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").contextMenu
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectContextMenuItem "&XXL"
session.findById("wnd[1]/usr/cmbG_LISTBOX").SetFocus
session.findById("wnd[1]/usr/cmbG_LISTBOX").Key = "31"
session.findById("wnd[1]/tbar[0]/btn[0]").press
session.findById("wnd[1]/usr/ctxtDY_PATH").Text = path
Dim name As String
name = Cells(a, 1) & ".xlsx"
session.findById("wnd[1]/usr/ctxtDY_FILENAME").Text = name
session.findById("wnd[1]/usr/ctxtDY_FILENAME").caretPosition = 10
session.findById("wnd[1]/tbar[0]/btn[0]").press
'line1:
Application.Wait Now + TimeValue("0:00:05")
If Not Dir(path & name, vbDirectory) = vbNullString Then
Dim wB1 As Workbook
Dim ws1 As Worksheet
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
Set wB1 = Workbooks.Open(path & name)
Set ws1 = wB.Sheets(1)
Application.Wait Now + TimeValue("0:00:05")
Workbooks(name).Activate
Workbooks(name).Close
Cells(a, 2) = "Done"
Else
Cells(a, 2) = "Please, check the order!"
End If
'Dim wB1 As Workbook
'Dim ws1 As Worksheet
'
' With Application
' .DisplayAlerts = False
' .EnableEvents = False
' .ScreenUpdating = False
' End With
'
' Set wB1 = Workbooks.Open(path & name)
' Set ws1 = wB.Sheets(1)
'
' Application.Wait Now + TimeValue("0:00:05")
'Workbooks(name).Activate
'
'Workbooks(name).Close
'
'Cells(a, 2) = "Checked"
line1:
Erase myArray_november1
Next a
Call invoice_extr_2
End Sub
extracting the invoice from SAP
Application.ScreenUpdating = False
SheetSrc = "Input data"
On Error Resume Next
If Not IsObject(SAPApplication) Then
Set SapGuiAuto = GetObject("SAPGUI")
If Err.Number <> 0 Then Exit Sub
Set SAPApplication = SapGuiAuto.GetScriptingEngine
If Err.Number <> 0 Then Exit Sub
End If
If Not IsObject(Connection) Then
Set Connection = SAPApplication.Children(0)
If Err.Number <> 0 Then
MsgBox ("Please, open SAP!")
Exit Sub
Else
End If
End If
If Not IsObject(session) Then
Set session = Connection.Children(0)
End If
On Error GoTo 0
Application.Wait (Now + TimeValue("0:00:01") / 1.5)
'####################################
'otwiera ordery i zapisuje faktury
'####################################
Workbooks("Saving_invoice.xlsm").Activate
Dim path As String
path = Cells(2, 6).Value
Dim last_row As Double
last_row = Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Double
For i = 2 To last_row
Dim name2 As String
name2 = Cells(i, 1) & ".xlsx"
Dim wB2 As Workbook
Dim ws2 As Worksheet
If Not Dir(path & name2, vbDirectory) = vbNullString Then
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
Set wB2 = Workbooks.Open(path & name2)
'Set ws2 = wB.Sheets(1)
Application.Wait Now + TimeValue("0:00:05")
Workbooks(name2).Activate
Else
GoTo line999999999
End If
Dim last_column As Integer
last_column = Cells(1, Columns.Count).End(xlToLeft).Column
'MsgBox (last_column)
Dim nr_kolumny As Long
nr_kolumny = Cells.Find(What:="Ref Document Number", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
If Cells(1, last_column) = "action" Then
Dim ostatnia_kolumna As Integer
ostatnia_kolumna = Cells.Find(What:="action", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
Else
ostatnia_kolumna = last_column + 1
End If
If Cells(1, last_column) = "action" Then
GoTo line2
Else
Cells(1, last_column + 1).Select
ActiveCell.FormulaR1C1 = "action"
End If
line2:
Dim k As Double
Dim last_row_document
last_row_document = Cells(Rows.Count, nr_kolumny).End(xlUp).Row - 2
For k = 2 To last_row_document
If Cells(k, ostatnia_kolumna) <> "Checked" Then
Workbooks("Saving_invoice").Activate
session.findById("wnd[0]").maximize
session.findById("wnd[0]/tbar[0]/okcd").Text = "/Ns_alr_87013019"
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]/usr/txt$6-KOKRS").Text = Cells(i, 4)
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").Text = Cells(i, 1)
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").SetFocus
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").caretPosition = 6
session.findById("wnd[0]/tbar[1]/btn[8]").press
On Error Resume Next
session.findById("wnd[0]/shellcont/shell/shellcont[2]/shell").hierarchyHeaderWidth = 453
session.findById("wnd[0]/usr/lbl[62,8]").SetFocus
session.findById("wnd[0]/usr/lbl[62,8]").caretPosition = 9
session.findById("wnd[0]").sendVKey 2
session.findById("wnd[1]/usr/lbl[1,2]").SetFocus
session.findById("wnd[1]/usr/lbl[1,2]").caretPosition = 4
session.findById("wnd[1]").sendVKey 2
'#####################################################
'##############WYBIERA LAYOUT /MACRO##################
'#####################################################
session.findById("wnd[0]/tbar[1]/btn[33]").press
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").currentCellRow = -1
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectColumn "VARIANT"
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").contextMenu
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectContextMenuItem "&FILTER"
session.findById("wnd[2]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").Text = "/MACRO"
session.findById("wnd[2]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").caretPosition = 6
session.findById("wnd[2]/tbar[0]/btn[0]").press
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectedRows = "0"
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").clickCurrentCell
'######################################################
'############TUTAJ FILTROWANIE PO DOKUMENCIE###########
'######################################################
Workbooks(name2).Activate
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").setCurrentCell -1, "REFBN"
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectColumn "REFBN"
session.findById("wnd[0]/tbar[1]/btn[29]").press
session.findById("wnd[1]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").Text = Cells(k, nr_kolumny)
session.findById("wnd[1]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").caretPosition = 8
session.findById("wnd[1]/tbar[0]/btn[0]").press
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").currentCellColumn = "REFBN"
'session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectedRows = "0"
'session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").doubleClickCurrentCell
'###########################################################
'####SPRAWDZA CZY JEST JUZ PLIK O TAKIEJ NAZWIE#############
'###########################################################
Dim objFSO_november As Object
Dim objFolder_november As Object
Dim objFile_november As Object
Dim objFile1_november As Object
Dim aa_november As Integer
Dim bb_november As Integer
Set objFSO_november = CreateObject("Scripting.FileSystemObject")
Set objFolder_november = objFSO_november.GetFolder(path)
bb_november = 0
For Each objFile1_november In objFolder_november.Files
bb_november = bb_november + 1
Next objFile1_november
Dim myArray_november() As Variant
ReDim Preserve myArray_november(bb_november, 1)
aa_november = 0
For Each objFile_november In objFolder_november.Files
myArray_november(aa_november, 1) = objFile_november.name
aa_november = aa_november + 1
Next objFile_november
Dim z As Double
Dim how_digits As Double
how_digits = Len(Cells(k, nr_kolumny))
Dim s As Double
s = 0
For z = 0 To aa_november
If Left(myArray_november(z, 1), how_digits) = Cells(k, nr_kolumny) Then
s = s + 1
End If
Next z
Erase myArray_november
Dim h As Double
Dim o As Double
o = 0
For h = 2 To k
If Cells(h, nr_kolumny) = Cells(k, nr_kolumny) Then
o = o + 1
End If
Next h
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectedRows = o - 1 'tutaj nr linii po filtrowaniu
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").doubleClickCurrentCell
session.findById("wnd[0]/titl/shellcont/shell").pressContextButton "%GOS_TOOLBOX"
session.findById("wnd[0]/titl/shellcont/shell").selectContextMenuItem "%GOS_VIEW_ATTA"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").pressToolbarContextButton "&MB_FILTER"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").selectContextMenuItem "&FILTER"
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/cntlCONTAINER1_FILT/shellcont/shell").currentCellRow = 2
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/cntlCONTAINER1_FILT/shellcont/shell").selectedRows = "2"
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/btnAPP_WL_SING").press
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/btn600_BUTTON").press
session.findById("wnd[3]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").Text = "Invoice"
session.findById("wnd[3]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").caretPosition = 7
session.findById("wnd[3]/tbar[0]/btn[0]").press
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").currentCellColumn = "BITM_DESCR"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").selectedRows = "0"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").pressToolbarButton "%ATTA_EXPORT"
session.findById("wnd[2]/usr/ctxtDY_PATH").Text = path
If s = 0 Then
session.findById("wnd[2]/usr/ctxtDY_FILENAME").Text = Cells(k, nr_kolumny).Value & ".PDF"
Else
session.findById("wnd[2]/usr/ctxtDY_FILENAME").Text = Cells(k, nr_kolumny).Value & "-" & s + 1 & ".PDF"
End If
session.findById("wnd[2]/usr/ctxtDY_FILENAME").caretPosition = 5
session.findById("wnd[2]/tbar[0]/btn[0]").press
session.findById("wnd[1]/tbar[0]/btn[12]").press
Application.Wait Now + TimeValue("0:00:05")
Workbooks(name2).Activate
Cells(k, ostatnia_kolumna) = "Checked"
Workbooks(name2).Save
End If
Next k
Workbooks("Saving_invoice").Activate
Cells(i, 3) = "Checked"
Workbooks("Saving_invoice.xlsm").Save
Workbooks(name2).Save
Workbooks(name2).Close
line999999999:
Next i
Workbooks("Saving_invoice.xlsm").Activate
If Cells(1, 11) = "action" Then
Columns("K:K").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
End If
Cells(1, 1).Activate
Workbooks("Saving_invoice.xlsm").Save
MsgBox ("Done")
End Sub
Well Application.Wait "The time at which you want the macro to resume, in Microsoft Excel date format." So it only pauses your VBA code but not "lets wait till some lines finishes work and we will continue" not sure how to write correctly :D bad in English. But hope you understood.
I suggest you to use Immediate window, and check everything is in place(values) with Debug.Print "My value: " & variable, also VBA is tricky and trying to make people less code while it automatically converts string, int and other stuff which is not declared or misspelled. So make on top "Option Explicit", then declare everything what is not declared.
And delete "On Error Resume Next", cause you cant see first error.
I have this VBA code which ends right after the big for loop, before "msgbox "h". The msgbox is to check if it continues. The code runs through the loop but nothing more. Can someone please help me understand why?
Sub countPT()
'Select file
Application.ScreenUpdating = False
Dim i As Integer, lastRow As Integer, tellerPoE(13) As Integer,
telleruPoE(13) As Integer, SwitchInd As Integer
Dim wb As Workbook, wb2 As Workbook
Dim krrom As String, Comment As String
For i = 1 To 13
tellerPoE(i) = 0
telleruPoE(i) = 0
Next i
Set wb = ActiveWorkbook
openFile = Application.GetOpenFilename("Excel-files,*.xls*", 1, _
"Select a file to open", , False)
Application.ScreenUpdating = False
If Len(openFile) = 0 Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
End
End If
Workbooks.Open openFile
Set wb2 = ActiveWorkbook
'Read through and count -> put to array on index
lastRow = wb2.Worksheets("Rådata").Range("F" & Rows.Count).End(xlUp).Row
For i = 114 To lastRow
wb2.Activate
If CStr(wb2.Worksheets("Rådata").Cells(i, "G")) = "528" Then
krrom = CStr(wb2.Worksheets("Rådata").Cells(i, "F"))
SwitchInd = SwitchCode(krrom)
'If SwitchInd = 0 Then
'GoTo ContinueLoop
'End If
Comment = LCase(CStr(wb2.Worksheets("Rådata").Cells(i, "M")))
If (InStr(Comment, "poe") Or InStr(Comment, "kamera") Or
InStr(Comment, "cam")) Then
If Len(wb2.Worksheets("Rådata").Cells(i, "L").Value) > 0 Then
tellerPoE(SwitchInd) = tellerPoE(SwitchInd) + 1
End If
tellerPoE(SwitchInd) = tellerPoE(SwitchInd) + 1
Else
If Len(wb2.Worksheets("Rådata").Cells(i, "L").Value) > 0 Then
telleruPoE(SwitchInd) = telleruPoE(SwitchInd) + 1
End If
telleruPoE(SwitchInd) = telleruPoE(SwitchInd) + 1
End If
'ContinueLoop
End If
Next i
'Check up to existing
'Update values
'Give message on change
MsgBox "h"
For j = 1 To 13
If tellerPoE(j) > CInt(Cells(5 + j, "E")) * 2 Or telleruPoE(j) >
CInt(Cells(5 + j, "G")) Then
Cells(6 + j, "K") = "Punkter økt"
End If
Cells(5 + j, "E") = tellerPoE(j)
Cells(5 + j, "G") = telleruPoE(j)
Next j
'Empty and close
Application.CutCopyMode = False
Set wb = ActiveWorkbook
wb2.Close
Application.ScreenUpdating = True
End Sub
Some of the code are commented out as to try to fix the problem or make it easier to find blocks
After the MsgBox, delete the loop and write the following:
MsgBox "h"
For j = 1 To 13
Cells(6 + j, "K") = "Punkter økt"
Next j
check whether it produces what you need. If it does, then it works and your condition is wrong.
can any one find any error? For some reason when i add last2 it gives na object defined error.
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim src As Workbook
' Abrir EXCEL
Set src = Workbooks.Open
("U:\Mecânica\Produção\Manutenção_teste\TOA\manTOA.xlsm", True, False)
WS_Count = src.Worksheets.Count
For o = 1 To WS_Count
src.Worksheets(o).Unprotect password:="projmanutencao"
Next o
last = src.Worksheets("Manutencao").Range("A65536").End(xlUp).Row
folha = manutencaoexp.Label27.Caption
last2 = src.Worksheets("saidas").Range("A65536").End(x1Up).Row
' Escrever Registos
If manutencaoexp.ComboBox4 = "" Then
MsgBox "Introduzir todos os dados"
GoTo fim
Else
src.Worksheets("Manutencao").Cells(last + 1, 1) = Now() 'data
src.Worksheets("Manutencao").Cells(last + 1, 2) = manutencaoexp.Label28.Caption 'nº equipamento
src.Worksheets("Manutencao").Cells(last + 1, 3) = manutencaoexp.ComboBox5 'avaria
src.Worksheets("Manutencao").Cells(last + 1, 4) = manutencaoexp.ComboBox4 'serviços
src.Worksheets("Manutencao").Cells(last + 1, 5) = manutencaoexp.ComboBox7 'produtos
src.Worksheets("Manutencao").Cells(last + 1, 6) = Application.ThisWorkbook.Worksheets(folha).Cells(Monitorform.ComboBox1.ListIndex + 2, 32).Text 'duração
src.Worksheets("Manutencao").Cells(last + 1, 7) = manutencaoexp.TextBox2 'operario
src.Worksheets("Manutencao").Cells(last + 1, 8) = manutencaoexp.ComboBox6 'tipo de manutenção
src.Worksheets("Manutencao").Cells(last + 1, 9) = manutencaoexp.TextBox3 'quantidade
src.Worksheets("saidas").Cells(last2 + 1, 1) = manutencaoexp.ComboBox7 'código/produtos
'manutencaoexp.Hide
manutencaoexp.ComboBox7 = ""
manutencaoexp.TextBox3 = ""
MsgBox "Dados Introduzidos com sucesso"
End If
For o = 1 To WS_Count
src.Worksheets(o).Protect password:="projmanutencao"
Next o
Application.DisplayAlerts = False 'IT WORKS TO DISABLE ALERT PROMPT
'SAVES FILE USING THE VARIABLE BOOKNAME AS FILENAME
src.Save
Application.DisplayAlerts = True 'RESETS DISPLAY ALERTS
' CLOSE THE SOURCE FILE.
src.Close True ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
fim:
End Sub
My problem is that i want to run
src.Worksheets("saidas").Cells(last2 + 1, 1) = manutencaoexp.ComboBox7
but i get na error on
last2 = src.Worksheets("saidas").Range("A65536").End(x1Up).Row
Other than that everything is running fine.
If there's any other way around to solve this error , maybe adding another button or something else.
last2 = src.Worksheets("saidas").Range("A65536").End(x1Up).Row
If you look VERY carefully at this line, you'll notice that you actually have the number 1 instead of the letter L in End(x1Up)
How that happened, I have no idea. So change the line to:
last2 = src.Worksheets("saidas").Range("A65536").End(xlUp).Row
I would like to be able to copy around 30k rows (to be exact, just some elements of the rows) from sheet A to sheet B, starting the destination from row nr 36155. Sometimes, we copy the row more than once, depending on the number in the G column. This is the macro I've written:
Sub copy()
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculate
Dim k As Long, k1 As Long, i As Integer
k = 36155
k1 = 30000
For i = 1 To k1
For j = 1 To Sheets("A").Range("G" & i + 2).Value
Sheets("B").Range("A" & k).Value = Sheets("A").Range("A" & i + 2).Value
Sheets("B").Range("B" & k).Value = Sheets("A").Range("B" & i + 2).Value
Sheets("B").Range("C" & k).Value = j
Sheets("B").Range("D" & k).Value = Sheets("A").Range("C" & i + 2).Value
Sheets("B").Range("E" & k).Value = Sheets("A").Range("D" & i + 2).Value
Sheets("B").Range("F" & k).Value = Sheets("A").Range("E" & i + 2).Value
Sheets("B").Range("G" & k).Value = Sheets("A").Range("F" & i + 2).Value
Sheets("B").Range("H" & k).Value = Sheets("A").Range("I" & i + 2).Value + (j - 1) * Sheets("A").Range("H" & i + 2).Value
Sheets("B").Range("I" & k).Value = Sheets("A").Range("J" & i + 2).Value
k = k + 1
Next j
Next i
Application.EnableEvents = True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Unfortunately, this macro takes a lot of time to run (around 10 minutes). I have a feeling that, there may be a better way to do that.. Do you have any ideas, how can we enchance the macro?
Try this using variant arrays: could be even faster if you can use a B array containing more than 1 row. This version takes 17 seconds on my PC.
Sub Copy2()
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculate
'
Dim k As Long, k1 As Long, i As Long, j As Long
Dim varAdata As Variant
Dim varBdata() As Variant
'
Dim dT As Double
'
dT = Now()
'
k = 36155
k1 = 30000
'
' get sheet A data into variant array
'
varAdata = Worksheets("A").Range("A1:J1").Resize(k1 + 2).Value2
'
For i = 1 To k1
'For j = 1 To Sheets("A").Range("G" & i + 2).Value
For j = 1 To varAdata(i + 2, 7)
'
' create empty row of data for sheet B and fill from variant array of A data
'
ReDim varBdata(1 to 1,1 to 9) As Variant
'Sheets("B").Range("A" & k).Value = Sheets("A").Range("A" & i + 2).Value
varBdata(1, 1) = varAdata(i + 2, 1)
varBdata(1, 2) = varAdata(i + 2, 2)
varBdata(1, 3) = j
varBdata(1, 4) = varAdata(i + 2, 3)
varBdata(1, 5) = varAdata(i + 2, 4)
varBdata(1, 6) = varAdata(i + 2, 5)
varBdata(1, 7) = varAdata(i + 2, 6)
varBdata(1, 8) = varAdata(i + 2, 9) + (j - 1) * varAdata(i + 2, 8)
varBdata(1, 9) = varAdata(i + 2, 10)
'
' write to sheet B
'
Sheets("B").Range("A1:I1").Offset(k - 1).Value2 = varBdata
k = k + 1
Next j
Next i
'
Application.EnableEvents = True
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox (Now() - dT)
End Sub
I would suggest you read your data into a recordset as shown here, then loop the recordset.
Try the following (untested).
Sub copy()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculate
.Calculation = xlCalculationManual
End With
Dim k As Long, i As Integer
k = 36155
' read data into a recordset
Dim rst As Object
Set rst = GetRecordset(ThisWorkbook.Sheets("A").UsedRange) 'feel free to hard-code your range here
With rst
While Not .EOF
For j = 1 To !FieldG
' !FieldG accesses the Datafield with the header "FieldG". Change this to the header you actually got in Column G, like "!MyColumnG" or ![columnG with blanks]
Sheets("B").Cells(k, 1).Value = !FieldA
' ... your code
k = k + 1
Next j
.movenext
Wend
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Also add the following Function into your VBA Module.
Function GetRecordset(rng As Range) As Object
'Recordset ohne Connection:
'https://usefulgyaan.wordpress.com/2013/07/11/vba-trick-of-the-week-range-to-recordset-without-making-connection/
Dim xlXML As Object
Dim rst As Object
Set rst = CreateObject("ADODB.Recordset")
Set xlXML = CreateObject("MSXML2.DOMDocument")
xlXML.LoadXML rng.Value(xlRangeValueMSPersistXML)
rst.Open xlXML
Set GetRecordset = rst
End Function
Note:
- using a recordset gives you additional options like filtering data
- with a recordset, your not dependent on the column-order of your input-data, meaning you don't have to adjust your macro if you decide to add another column to sheet A (as long as you keep the headers the same)
Hope this helps.
I am trying to copy one row to an other workbook (only if there is a match) and i can accomplish that with a simple loop but i would like to use some better and possibly quicker method:
Set wbk = Workbooks.Open(FROM)
Set wskz = wbk.Worksheets("Sheet1")
Set wbi = Workbooks.Open(TO)
Set wski = wbi.Worksheets("Sheet1")
si = 5
Do While wski.Cells(si, 1).Text <> "END" ' loop through the values in column "A" in the "TO" workbook
varver = wski.Cells(si, 1).Text ' data to look up
s = 5
Do While wskz.Cells(s, 1).Text <> "END" ' table where we search for the data in the "FROM" workbook
If wskz.Cells(s, 1).Text = varver Then Exit Do
s = s + 1
Loop
If wskz.Cells(s, 1).Text <> "END" Then
' I am trying this copy method to replace the loop but it throws an error
wskz.Range(Cells(s, 1), Cells(s, 250)).Copy Destination:=wski.Range(Cells(si, 1), Cells(si, 250))
' this is the working loop:
'For i = 1 To 250
' wskz.Cells(s, i) = wski.Cells(si, i)
' i = i + 1
'End If
'Next i
The problem with the new copying method throws an error as it can be seen above.
Thank you in advance for your help!
Try to replace :
wskz.Range(Cells(s, 1), Cells(s, 250)).Copy Destination:=wski.Range(Cells(si, 1), Cells(si, 250))
by
wskz.Range(wskz.Cells(s, 1), wskz.Cells(s, 250)).Copy Destination:=wski.Range(wski.Cells(si, 1), wski.Cells(si, 250))
Or by :
Dim Rng1 As Range, Rng2 As Range
Set Rng1 = wskz.Range(wskz.Cells(s, 1), wskz.Cells(s, 250))
Set Rng2 = wski.Range(wski.Cells(si, 1), wski.Cells(si, 250))
Rng1.Copy Rng2
This should do exactly what you are looking for:
Sub test()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Dim SourceWS As Worksheet, DestWS As Worksheet
Set SourceWS = Workbooks.Open("FROM").Worksheets("Sheet1")
Set DestWS = Workbooks.Open("TO").Worksheets("Sheet1")
Dim runner As Variant, holder As Range
If IsError(Application.Match("END", DestWS.Range("A5:A" & Rows.Count), 0)) Or IsError(Application.Match("END", SourceWS.Range("A5:A" & Rows.Count), 0)) Then
SourceWS.Parent.Close False
DestWS.Parent.Close False
Exit Sub
End If
Set holder = DestWS.Range("A5:A" & Application.Match("END", DestWS.Range("A5:A" & Rows.Count), 0) + 3)
For Each runner In SourceWS.Range("A5:A" & Application.Match("END", SourceWS.Range("A5:A" & Rows.Count), 0) + 3)
If IsNumeric(Application.Match(runner.Value, holder, 0)) Then runner.EntireRow.Copy DestWS.Rows(Application.Match(runner.Value, holder, 0) + 4)
Next
SourceWS.Parent.Close True
DestWS.Parent.Close True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub
It is self-explaining to my eye, but if you have any questions, just ask :)
This Error often occures related to Copy-Methods. I also ran into this kind of Error when I had my Sub on Worksheet Level. Try to extract it to a seperate Modul.
Also it seems your references to the Cells are broken. You can find this explained in the docs for Range.Item.
Try this
With wskz
.Range(.Cells(s, 1), .Cells(s, 250)).Copy
End With