Sunnych
Full Member | Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
Есть вот такой макрос он проходит по шапке (в шапке заданы месяца) и определяет таким образом начальный и конечный столбец области определения для изъятия и замены информации находящейся в ячейках, проблема такого рода ранее ячейки с месяцами были текстовыми, а теперь они в формате дата "Date", и я не знаю как мне переделать функции "Function" так что макрос работал как раньше.
Код: Function ПолучитьЛист(ИмяЛиста) As Worksheet
Dim tmpWSh As Worksheet
On Error Resume Next
Set tmpWSh = ActiveWorkbook.Sheets(ИмяЛиста)
If Err.Number <> 0 Then
Set tmpWSh = ActiveWorkbook.Sheets.Add
tmpWSh.Name = ИмяЛиста
Else
tmpWSh.UsedRange.Clear
End If
On Error GoTo 0
Set ПолучитьЛист = tmpWSh
End Function
Function ЭтоМесяц(ТекстЗнач) As Boolean
Dim AllMonth As String
ЭтоМесяц = False
ТекстЗнач = LCase(ТекстЗнач)
If InStr(1, "янв.08,фев.08,мар.08,апр.08,май.08,июн.08,июл.08,авг.08,сен.08,окт.08,ноя.08,дек.08", ТекстЗнач) > 0 Then
ЭтоМесяц = True
End If
End Function
Function ПолучитьНомерМесяца(ТекстЗнач) As Integer
Dim StartPos As Integer
Dim i As Integer
Dim MonthNumber As Integer
MonthNumber = 0
StartPos = InStr(1, "янв.08,фев.08,мар.08,апр.08,май.08,июн.08,июл.08,авг.08,сен.08,окт.08,ноя.08,дек.08", ТекстЗнач)
For i = 1 To StartPos
If Mid$("янв.08,фев.08,мар.08,апр.08,май.08,июн.08,июл.08,авг.08,сен.08,окт.08,ноя.08,дек.08", i, 1) = "," Then
MonthNumber = MonthNumber + 1
End If
Next i
ПолучитьНомерМесяца = MonthNumber + 1
End Function
Sub Sunnych_current_txt()
' Саныч Макрос
' Макрос записан 5.02.2008 (Sunnych)
Dim SH As Worksheet
Dim iCol As Integer
Dim iStartCol As Integer
Dim iMaxCol As Integer
Dim iRow As Integer
Dim iMaxRow As Integer
Dim vVar1 As Variant
Dim strT1 As String
Dim intOffset As Integer
Set SH = ПолучитьЛист("Лист3")
iStartCol = 0
iMaxCol = Sheets("Лист1").UsedRange.Columns.Count + Sheets("Лист1").UsedRange.Column - 1
For iCol = 3 To iMaxCol
Debug.Print Sheets("Лист1").UsedRange.Columns(iCol).Width
If (Sheets("Лист1").UsedRange.Columns(iCol).Width > 1) And (iStartCol = 0) Then
iStartCol = iCol
Exit For
End If
Next iCol
intOffset = iStartCol - ПолучитьНомерМесяца(LCase(Trim$(Sheets("Лист1").Cells(8, iStartCol).Text)))
For iCol = iStartCol To iMaxCol
Debug.Print Sheets("Лист1").UsedRange.Columns(iCol).Width
If Sheets("Лист1").UsedRange.Columns(iCol).Width > 3 Then
strT1 = Trim$(Sheets("Лист1").Cells(8, iCol).Text)
If ЭтоМесяц(strT1) = False Then
Exit For
End If
SH.Cells(1, ПолучитьНомерМесяца(strT1)).FormulaR1C1 = strT1
SH.Cells(1, ПолучитьНомерМесяца(strT1)).NumberFormat = "[$-419]mmmm yyyy"
End If
Next iCol
iMaxCol = iCol - 1
iRow = 9
Do While Trim$(Sheets("Лист1").Cells(iRow, 1).Text) <> ""
For iCol = iStartCol To iMaxCol
strT1 = Trim$(Sheets("Лист1").Cells(iRow, iCol).Text)
If sText = "" Then
sText = "0"
ElseIf sText = "резерв" Then
sText = "0R"
ElseIf sText = "с 15" Then
sText = "занят с 15"
ElseIf sText = "до 15" Then
sText = "занят до 15"
Else
sText = "1"
End If
SH.Cells(iRow - 7, iCol - intOffset).NumberFormat = ""
Next iCol
iRow = iRow + 1
Loop
For iCol = 1 To SH.UsedRange.Columns.Count
If SH.Cells(1, iCol).Text <> "" Then
iStartCol = iCol
Exit For
End If
Next iCol
SH.Activate
For iCol = 1 To iStartCol - 1
SH.Range(Cells(2, iStartCol), Cells(SH.UsedRange.Rows.Count, iStartCol)).Select
Selection.Copy
SH.Cells(2, iCol).Select
SH.Paste
Next iCol
SH.Select
For iCol = SH.UsedRange.Columns.Count + 1 To 12
SH.Range(Cells(2, SH.UsedRange.Columns.Count), Cells(SH.UsedRange.Rows.Count, SH.UsedRange.Columns.Count)).Select
Selection.Copy
SH.Cells(2, iCol).Select
SH.Paste
Next iCol
SH.Activate
SH.Range(SH.Cells(1, 1), SH.Cells(SH.UsedRange.Rows.Count, SH.UsedRange.Columns.Count)).Select
Selection.Copy
End Sub |
|
, остальное попробую доделать сам.
