Страницы: 1
RSS
[ Закрыто ] Изменить макрос
 
Здравствуйте, в макросах я полный чайник и прошу помощи) На работе есть прекрасная таблица выгружающая из базы R-keeper отчет, но только за 1 день, а нужно за период дат, подскажите пожалуйста, что нужно изменить. Вот сам макрос

Public Declare PtrSafe Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long
Declare PtrSafe Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
                                        (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _
                                         ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare PtrSafe Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
                                          (ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
                                          ByVal lpString As Any, ByVal lpFileName As String) As Long
Sub Get_Server()
' что ишем в вайле
' [BKC File Directory]
' Path=\\10.0.63.2\posdataforbkc
' ActiveWindow.DisplayWorkbookTabs = True
Sheets("Setup").Select
ActiveSheet.Range("C25").Value = ""
ActiveSheet.Range("C25").Value = RIF("Path", "Ошибка", "BKC File Directory", "C:\Program Files (x86)\ICC\POSInterface\PCMinder.INI")
If ActiveSheet.Range("C25").Value = "Ошибка" Then
   ActiveSheet.Range("C25").Value = RIF("Path", "Ошибка", "BKC File Directory", "C:\Program Files\ICC\POSInterface\PCMinder.INI")
End If
If ActiveSheet.Range("C25").Value = "Ошибка" Then
   ActiveSheet.Range("C25").Value = RIF("Path", "Сделайте заявку в UCS", "BKC File Directory", "D:\Distr\ICC\POSInterface\PCMinder.INI")
End If
End Sub
Public Function RIF(ByVal sName$, ByVal DefVal$, ByVal sPart$, ByVal FilePath$) As String
' функция ищет в ini файле FilePath$ раздел sPart$,
' и читает из него значение параметра с именем sName$
' Если такой параметр не найден, возвращается значение по умолчанию DefVal$
Const strNoValue As String = ""
Dim intRet As Integer   'Длина возвращаемой строки (функцией GetPrivateProfileString)
Dim strRet As String    'Возвращаемая строка
  'Получаем значение из файла - если его нет будет возвращен 3й аргумент = strNoValue
  strRet = String(255, Chr(0)): intRet = GetPrivateProfileString(sPart, sName, strNoValue, strRet, 255, FilePath)
  strRet = Left$(strRet, intRet)
  'Определяем было найдено значение или нет (если возвращено знач. константы strNoValue то = НЕТ)
  If strRet = strNoValue Then strRet = DefVal   'Значение не было найдено - возвращаем значение по умолчанию
  RIF = strRet
End Function
Public Sub WIF(ByVal sName$, ByVal val$, ByVal sPart$, ByVal FilePath$)
   ' функция ищет в ini файле FilePath$ раздел sPart$ (если раздела нет - он создаётся),
  ' и добавляет в него параметра с именем sName$ и значением val
  Dim intRet As Integer: intRet = WritePrivateProfileString(sPart, sName, val, FilePath)
   'If intRet <> 1 Then 'Неудачное завершение'(Проверка результата записи)
End Sub


Sub Load_All()
   Call Get_Server
   Call POS_PMIXloading101
   Sheets("MENU").Select
   MsgBox "Загружено", vbInformation, "yelovik"
End Sub


Sub POS_PMIXloading101()
Dim sFileName As String
Dim sPathName As String
Dim sDateMask As String
Dim sMonth As String
Dim sDay As String
Dim maestro As String
Dim esclavo2 As String

   Application.ScreenUpdating = True
   On Error GoTo Trapper
   maestro = ThisWorkbook.Name
   Call ERASE_PLUDATA
   If Left(Range("workdir"), 2) = "\\" Then
       sPathName = Range("workdir")
   Else
       sPathName = "\" & Range("workdir")
   End If
   
   SetCurrentDirectoryA sPathName
   
   If (Range("MonthUpload") < 10) Then
   sMonth = "0" & Range("MonthUpload")
   Else
      sMonth = Range("MonthUpload")
   End If
   If (Range("DayUpload") < 10) Then
       sDay = "0" & Range("DayUpload")
   Else
       sDay = Range("DayUpload")
   End If
   
   sDateMask = Range("YearUpload") & "." & sMonth & "." & sDay

   sFileName = Dir(sPathName & "\MenuItemSales*" & sDateMask & ".csv")
   If sFileName = "" Then MsgBox "Файл продаж MenuItemSales за указанную дату не найден", vbInformation, "yelovik"
   Workbooks.OpenText Filename:=sFileName, Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
       ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=","
   
   esclavo2 = ActiveWorkbook.Name
   Range("A1:c1000").Copy
   Application.DisplayAlerts = False
   Workbooks(maestro).Activate
   Sheets("PLUDATA").Select
   Range("A2").Select
   ActiveSheet.Paste
   
   Columns("C:C").Select
   Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
   
   Workbooks(esclavo2).Close False
   Application.DisplayAlerts = True
   Range("A1").Select
   Sheets("GPMIX").Select
   Call DesProtegeresto
   Range("N21:N350").Select
   Range(Selection, Selection.End(xlDown)).Select
   Range("N21:N350").Select
   Selection.Copy
   Range("B21").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
   Range("B19").Select
   Call Protegeresto
   Range("pmixdate") = Range("pludate")
   Call testwe
Trapper:
   If Err = 18 Then MsgBox Error(Err)
   Application.StatusBar = False
End Sub
Изменено: yelovik - 21.11.2019 16:07:37
 
Вот "мне надо!", а ознакомиться с порядками времени нет...
Правила форума - о файле-примере, о названии темы. Код в сообщении нужно оформлять тэгами (кнопка <...>). Длинные листинги прятать под спойлер (кнопка sp)
Страницы: 1
Наверх