Új hozzászólás Aktív témák

• #47881 eszgé100 őstag Fferi50 #44543

  Új Válasz 2021-11-28 01:09:28 #47881

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  eszgé100

  őstag

  válasz Fferi50 #44543 üzenetére

  "Nem tudom hány xls-ed van, de nem hiszem, hogy mindegyiket külön-külön el kellene látni ugyanazon funkciókat végző makrókkal. Én egy alap Excelt használnék, amiben a makrók benne vannak és abból intézném az összes többinek a megnyitását és kezelését. Így csak egy fájlt kell karbantartani, nem pedig x db-ot.
  De lehet, hogy rosszul látom.
  Üdv."

  Üdv Fferi50,

  Nem láttad rosszul a dolgokat, jelenleg így állok a dologgal:

  

  

  Ez a kód lefut megnyitáskor:

  Option Explicit
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_QUERY_VALUE = &H1&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234

Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32" _
Alias "RegOpenKeyExA" ( _
ByVal HKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long

Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" ( _
ByVal HKey As Long, _
ByVal dwIndex As Long, _
ByVal lpValueName As String, _
lpcbValueName As Long, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Byte, _
lpcbData As Long) As Long

Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
ByVal HKey As Long) As Long
Public Function GetPrinterFullNames() As String()
Dim Printers() As String ' array of names to be returned
Dim PNdx As Long ' index into Printers()
Dim HKey As Long ' registry key handle
Dim Res As Long ' result of API calls
Dim Ndx As Long ' index for RegEnumValue
Dim ValueName As String ' name of each value in the printer key
Dim ValueNameLen As Long ' length of ValueName
Dim DataType As Long ' registry value data type
Dim ValueValue() As Byte ' byte array of registry value value
Dim ValueValueS As String ' ValueValue converted to String
Dim CommaPos As Long ' position of comma character in ValueValue
Dim ColonPos As Long ' position of colon character in ValueValue
Dim M As Long ' string index

' registry key in HCKU listing printers
Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"

PNdx = 0
Ndx = 0
' assume printer name is less than 256 characters
ValueName = String$(256, Chr(0))
ValueNameLen = 255
' assume the port name is less than 1000 characters
ReDim ValueValue(0 To 999)
' assume there are less than 1000 printers installed
ReDim Printers(1 To 1000)

' open the key whose values enumerate installed printers
Res = RegOpenKeyEx(HKCU, PRINTER_KEY, 0&, _
KEY_QUERY_VALUE, HKey)
' start enumeration loop of printers
Res = RegEnumValue(HKey, Ndx, ValueName, _
ValueNameLen, 0&, DataType, ValueValue(0), 1000)
' loop until all values have been enumerated
Do Until Res = ERROR_NO_MORE_ITEMS
M = InStr(1, ValueName, Chr(0))
If M > 1 Then
' clean up the ValueName
ValueName = Left(ValueName, M - 1)
End If
' find position of a comma and colon in the port name
CommaPos = InStr(1, ValueValue, ",")
ColonPos = InStr(1, ValueValue, ":")
' ValueValue byte array to ValueValueS string
On Error Resume Next
ValueValueS = Mid(ValueValue, CommaPos + 1, ColonPos - CommaPos)
On Error GoTo 0
' next slot in Printers
PNdx = PNdx + 1
Printers(PNdx) = ValueName & " on " & ValueValueS
' reset some variables
ValueName = String(255, Chr(0))
ValueNameLen = 255
ReDim ValueValue(0 To 999)
ValueValueS = vbNullString
' tell RegEnumValue to get the next registry value
Ndx = Ndx + 1
' get the next printer
Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
0&, DataType, ValueValue(0), 1000)
' test for error
If (Res <> 0) And (Res <> ERROR_MORE_DATA) Then
Exit Do
End If
Loop
' shrink Printers down to used size
ReDim Preserve Printers(1 To PNdx)
Res = RegCloseKey(HKey)
' Return the result array
GetPrinterFullNames = Printers
End Function
Sub Auto_Open()

Dim start As Date
Dim weekcom As Date
Dim today As Date
start = Sheets("MainAssembly").Range("F3").Value
today = Sheets("MainAssembly").Range("F7").Value
weekcom = start
Do While weekcom < today
weekcom = weekcom + 28
Loop
Sheets("MainAssembly").Range("F6").Value = weekcom

Dim Printers() As String
Dim N As Long
Dim S As String
Dim col As String
Dim bw As String

Printers = GetPrinterFullNames()

For N = LBound(Printers) To UBound(Printers)
S = Printers(N) 'S & Printers(N) & vbNewLine
If InStr(S, "Microsoft") <> 0 And InStr(S, "Print") <> 0 Then col = S
If InStr(S, "HP Photosmart Wireless B109n-z") <> 0 And InStr(S, "Print") = 0 Then bw = S
Next N

Sheets("MainAssembly").Range("F8").Value = col
Sheets("MainAssembly").Range("F9").Value = bw

MsgBox col, vbOKOnly, "Colour Printer"
MsgBox bw, vbOKOnly, "BW Printer"

End Sub

  Ez pedig elvégzi a piszkos munkát:

  Sub EOM_Main_Assy_Workbooks()

'loop:
Dim sPath As String, ssheet As String, fileName As String
Dim lastrow As Long, counter As Long
Dim ws As Worksheet, tp As Worksheet, ma As Worksheet
'printers:
Dim bw As String, col As String
'from main worksheet:
Dim sDate As String
Dim sWeek As String
Dim sWkcom As String
Dim nextmonth As Date
'from Table:
Dim freq As String
Dim area As String
Dim loc As String
Dim dat As String
Dim week As String
Dim wkcom As String
Dim procloc As String
Dim procname As String
Dim machloc As String
Dim machname As String
Dim printer As String
Dim copies As Integer
Dim saveandclose As String


sDate = "=[FillerPrinter.xlsm]MainAssembly!$F$4"
sWeek = "=[FillerPrinter.xlsm]MainAssembly!$F$5"
sWkcom = "=[FillerPrinter.xlsm]MainAssembly!$F$6"

Set ma = Workbooks("FillerPrinter.xlsm").Worksheets("MainAssembly")

nextmonth = ma.Range("F4")
col = ma.Range("F9")
bw = ma.Range("F9")


Set ws = Workbooks("FillerPrinter.xlsm").Worksheets("OpenClose")

lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
counter = 2



Do While counter <= lastrow

ws.Activate

freq = Range("A" & counter)
area = Range("B" & counter)
loc = Range("C" & counter)
sPath = Range("D" & counter)
ssheet = Range("E" & counter)
dat = Range("F" & counter)
week = Range("G" & counter)
wkcom = Range("H" & counter)
procloc = Range("I" & counter)
procname = Range("J" & counter)
machloc = Range("K" & counter)
machname = Range("L" & counter)
printer = Range("M" & counter)
copies = Range("N" & counter)
saveandclose = Range("O" & counter)



'freq check

Select Case CStr(freq)

Case "4 weekly"
GoTo openworksheets

Case "monthly"
GoTo openworksheets

Case "2 monthly"
Select Case Month(nextmonth)
Case 1, 3, 5, 7, 9, 11
GoTo openworksheets
Case Else
GoTo nextraw
End Select

Case "3 monthly"
Select Case Month(nextmonth)
Case 1, 4, 7, 10
GoTo openworksheets
Case Else
GoTo nextraw
End Select

Case Else
GoTo nextraw

End Select

'open sheets

openworksheets:
Workbooks.Open sPath

fileName = Right(sPath, Len(sPath) - InStrRev(sPath, "\"))


'update sheets if necessary

Set tp = Workbooks(fileName).Worksheets(CStr(ssheet))

If CStr(dat) <> "" Then
Sheets(ssheet).Select
Range(dat).Select
ActiveCell.Formula = sDate
End If

If CStr(week) <> "" Then
Sheets(ssheet).Select
Range(week).Select
ActiveCell.Formula = sWeek
End If

If CStr(wkcom) <> "" Then
Sheets(ssheet).Select
Range(wkcom).Select
ActiveCell.Formula = sWkcom
End If

If CStr(procloc) <> "" Then
Sheets(ssheet).Select
Range(procloc).Select
ActiveCell.Formula = procname
End If

If CStr(machloc) <> "" Then
Sheets(ssheet).Select
Range(machloc).Select
ActiveCell.Formula = machname
End If

'print sheets

Select Case CStr(printer)
Case "col"
Application.ActivePrinter = col
tp.PrintOut copies:=CStr(copies)


Case "bw"
Application.ActivePrinter = bw
tp.PrintOut copies:=CStr(copies)
Case Else
MsgBox "No printer selected"
End Select


'wait here a bit
Do While ActiveWindow.View = xlPrint
Loop

'time to save&close

If CStr(saveandclose) = "yes" Then
Excel.Workbooks(fileName).Close SaveChanges:=True
Else: GoTo nextraw
End If

nextraw:
counter = counter + 1

Loop


Worksheets("MainAssembly").Select
Range("A1").Select

MsgBox "Done!"

End Sub

  Ez nem az összes workbook, amivel foglalkoznom kell, de egyelőre tesztnek elegendőek ezek is. Jelenlegi formájában a kód 88 sheetet kevesebb, mint 2 perc alatt megnyitott, update-elt, nyomtatóra küldött, majd bezárt

  Már csak szűrést és hibakezelést kellene beleszőnöm valahogy.
  Az egész csoportnak köszönöm mégegyszer az eddigi segítséget

Új hozzászólás Aktív témák