Related
Could you anybody help me how to split word file by character!
I can't find any way to split word files by the number of characters on the internet!
For example, to split a document into 500-character blocks:
Sub SplitDocument()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long, j As Long
Const Char As Long = 500
With ActiveDocument
' Process each character block
For i = 1 To Int(.Characters.Count / Char)
j = j + 1
' Get the character block
Set Rng = .Range((i - 1) * Char, i * Char)
' Copy the character block
Rng.Copy
Rng.Collapse wdCollapseEnd
Call NewDoc(ActiveDocument, (i - 1) * Char + 1, j)
Next
If Rng.End < .Range.End Then
i = i + 1: j = j + 1
Rng.End = .Range.End
' Copy the range
Rng.Copy
Rng.Collapse wdCollapseEnd
Call NewDoc(ActiveDocument, (i - 1) * Char + 1, j)
End If
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Sub NewDoc(DocSrc As Document, i As Long, j As Long)
Dim DocTgt As Document, HdFt As HeaderFooter
' Create the output document
Set DocTgt = Documents.Add(Visible:=False)
With DocTgt
' Paste contents into the output document, preserving the formatting
.Range.PasteAndFormat (wdFormatOriginalFormatting)
' Replicate the headers & footers
For Each HdFt In DocSrc.Sections(DocSrc.Characters(i).Sections(1).Index).Headers
.Sections(1).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
For Each HdFt In DocSrc.Sections(DocSrc.Characters(i).Sections(1).Index).Footers
.Sections(1).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
' Save & close the output document
.SaveAs FileName:=Split(DocSrc.FullName, ".doc")(0) & "_" & j & ".docx", _
FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Set DocTgt = Nothing: Set DocSrc = Nothing
End Sub
I took a QB45 application and produced a QB64 application from it over 100,000 lines of code. All the pricing was hard coded in the program so I started reading from CSV files but now I need the date from the CSV file without putting a directory to a text file and reading for the date. I found this code below
The problem when I run it is that the assembler is for 16 bit registers and I am using 32 or 64 with windows 7 and i5 core. Can anyone help me to figure out how the date will be returned in a longer int value from the register?
'===========================================================================
' Subject: GET/SET FILE DATE/TIME Date: Unknown Date (00:00)
' Author: Matt Hart Code: QB, PDS
' Keys: GET,SET,FILE,DATE,TIME Packet: DOS.ABC
'===========================================================================
' FILEDATE.BAS by Matt Hart
'
' Gets or sets a file date/time
'
' GetFileDateTime returns the Date in MM-DD-YYYY format
' and the Time in HH:MM:SS
' SetFileDateTime expects the Date and Time in the same formats
'$INCLUDE: 'QB.BI' ' Use your path to QB or QBX.BI
DEFINT A-Z
DECLARE SUB GetFileDateTime (F$, Dat$, Tim$, Ecode%)
DECLARE SUB SetFileDateTime (F$, Dat$, Tim$, Ecode%)
' ------------------------- Sample code
F$ = LTRIM$(RTRIM$(COMMAND$))
CALL GetFileDateTime(F$, Dat$, Tim$, Ecode)
IF NOT Ecode THEN
PRINT F$; " date is "; Dat$
PRINT F$; " time is "; Tim$
ELSE
PRINT "1 Error = "; Ecode
END
END IF
NewTim$ = "01:01:02"
NewDat$ = "02-02-1980"
CALL SetFileDateTime(F$, NewDat$, NewTim$, Ecode)
IF Ecode THEN
PRINT "2 Error = "; Ecode
END
END IF
CALL GetFileDateTime(F$, Dat$, Tim$, Ecode)
IF Ecode THEN
PRINT "3 Error = "; Ecode
END
END IF
PRINT F$; " new date is "; Dat$
PRINT F$; " new time is "; Tim$
CALL SetFileDateTime(F$, Dat$, Tim$, Ecode)
IF Ecode THEN
PRINT "4 Error = "; Ecode
END
END IF
END
' ------------------------------------
SUB GetFileDateTime (F$, Dat$, Tim$, Ecode)
Ecode = 0
DIM InRegs AS RegTypeX
DIM OutRegs AS RegTypeX
InRegs.ax = &H3D00 ' Open file function
DIM FileName AS STRING * 128 ' Use fixed length
FileName = F$ + CHR$(0) ' Must be ASCIIZ string
InRegs.ds = VARSEG(FileName) ' Fixed length makes these
InRegs.dx = VARPTR(FileName) ' come out right
CALL INTERRUPTX(&H21, InRegs, OutRegs) ' Open the file
IF NOT OutRegs.flags THEN ' No error
Handle = OutRegs.ax ' Save DOS file handle
InRegs.ax = &H5700 ' Get date/time function
InRegs.bx = Handle
CALL INTERRUPTX(&H21, InRegs, OutRegs)
HMS& = OutRegs.cx ' Use long integer for
IF HMS& < 0& THEN HMS& = 65536 + HMS& ' positive numbers
Hours = HMS& \ 2048& ' Hours is first 5 bits
Minutes = (HMS& AND 2047&) \ 31& ' Minutes is next 6 bits
Seconds = HMS& AND 31& ' Seconds is last 5 bits
H$ = LTRIM$(STR$(Hours))
M$ = LTRIM$(STR$(Minutes)): IF LEN(M$) = 1 THEN M$ = "0" + M$
S$ = LTRIM$(STR$(Seconds)): IF LEN(S$) = 1 THEN S$ = "0" + S$
Tim$ = H$ + ":" + M$ + ":" + S$
YMD& = OutRegs.dx ' Long int here too
IF YMD& < 0 THEN YMD& = 65536 + YMD& ' Convert to + if needed
Year = 1980& + YMD& \ 512& ' Year is first 7 bits
Month = (YMD& AND 511&) \ 31& ' Month is next 4 bits
Day = YMD& AND 31& ' Day is last 5 bits
Y$ = LTRIM$(STR$(Year))
M$ = LTRIM$(STR$(Month))
D$ = LTRIM$(STR$(Day)): IF LEN(D$) = 1 THEN D$ = "0" + D$
Dat$ = M$ + "-" + D$ + "-" + Y$
InRegs.ax = &H3E00 ' Close file function
InRegs.bx = Handle
CALL INTERRUPTX(&H21, InRegs, OutRegs) ' Close it
ELSE
Ecode = OutRegs.flags ' Otherwise return error flags
END IF
END SUB
SUB SetFileDateTime (F$, Dat$, Tim$, Ecode)
Ecode = 0
DIM InRegs AS RegTypeX
DIM OutRegs AS RegTypeX
InRegs.ax = &H3D00
DIM FileName AS STRING * 128
FileName = F$ + CHR$(0)
InRegs.ds = VARSEG(FileName)
InRegs.dx = VARPTR(FileName)
CALL INTERRUPTX(&H21, InRegs, OutRegs)
IF NOT OutRegs.flags THEN
Handle = OutRegs.ax
InRegs.ax = &H5701
InRegs.bx = Handle
Hours& = VAL(LEFT$(Tim$, 2)) * 2048&
Minutes& = VAL(MID$(Tim$, 4, 2)) * 32&
Seconds& = VAL(RIGHT$(Tim$, 2)) \ 2
HMS& = Hours& + Minutes& + Seconds&
IF HMS& > 65536 THEN
InRegs.cx = 65536 - HMS&
ELSE
InRegs.cx = HMS&
END IF
Year& = (VAL(RIGHT$(Dat$, 4)) - 1980&) * 512&
Month& = VAL(LEFT$(Dat$, 2)) * 32&
Day& = VAL(MID$(Dat$, 4, 2))
YMD& = Year& + Month& + Day&
IF YMD& > 65536 THEN
InRegs.dx = 65536 - YMD&
ELSE
InRegs.dx = YMD&
END IF
CALL INTERRUPTX(&H21, InRegs, OutRegs)
InRegs.ax = &H3E00
InRegs.bx = Handle
CALL INTERRUPTX(&H21, InRegs, OutRegs)
ELSE
Ecode = OutRegs.flags
END IF
END SUB
I've been trying for days to create charts with an intelligent range, that differs when the data in the google spreadsheet is updated. However i succeeded doing so, i can't get the .setOption aspect to work. I want for example, a title, description etc with the chart. But this is not the main issue since i can insert there by hand.
More important however is the range name, because there isn't when i use the script. So, within the chart it is not possible to see what each column represents, and i really want to fix that. I tried to use the .setNamedRange() aspects, but that is not working.
Someone who can help me with that?
function check() {
var sheet = SpreadsheetApp.getActiveSheet();
var end = sheet.getLastRow();
var start = (end - 5);
var endnew = (end - 4);
var startnew = (end - 6);
if(sheet.getCharts().length == 0){
Logger.log("Er is geen grafiek");
var chartBuilder = sheet.newChart()
.asColumnChart().setStacked()
.addRange(sheet.getRange("A" + startnew + ":" + "A" + endnew)) // should have a name
.addRange(sheet.getRange("B" + startnew + ":" + "B" + endnew)) // should have a name
.addRange(sheet.getRange("E" + startnew + ":" + "E" + endnew)) //should have a name
.setOption('title', 'Effectief gebruik kantoorruimte') //not working
.setPosition(10, 10, 0, 0)
var chart = chartBuilder.build();
sheet.insertChart(chart);
}
else{
Logger.log("Er is wel een grafiek");
var charts = sheet.getCharts();
for (var i in charts) {
var chart = charts[i];
var ranges = chart.getRanges();
var builder = chart.modify();
for (var j in ranges) {
var range = ranges[j];
builder.removeRange(range);
builder
.addRange(sheet.getRange("A" + (start) + ":" + "A" + end)) //should have a name
.addRange(sheet.getRange("B" + (start) + ":" + "B" + end)) //should have a name
.addRange(sheet.getRange("E" + (start) + ":" + "E" + end)) // should have a name
.setOption('title', 'Effectief gebruik kantoorruimte')
.build();
sheet.updateChart(builder.build());
}
}
}
}
I'm assuming that this code is the issue?
builder
.addRange(sheet.getRange("A" + (start) + ":" + "A" + end))
Maybe try using the JavaScript toString() method to make sure that your text formula is working.
.addRange(sheet.getRange("A" + start.toString() + ":" + "A" + end.toString()))
There is a different format that you can use:
getRange(row, column, numRows, numColumns)
So, it would be:
getRange(start, 1, 1, numColumns)
That starts on row "start" in column A. It gets one row of data, and how ever many number of columns.
I have come across a challenging task which I am not able to solve using many workarounds.
In one column I have dates, the date can be in following three formats:
1) Simple dd/mm/yy
2) dd/mm/yy but may have words "before,after or about" around it. Any
one of it and we just need to delete those words in this case.
3) Date in a numeric format. A long decimal values like 1382923.2323
but actually I can get a date from it after conversion.
The file is uploaded here. Date_format_macro_link
I wrote the following code but it's giving wrong results.
Sub FormatDates_Mine()
ManualSheet.Activate
ManualSheet.Cells.Hyperlinks.Delete
ManualSheet.Cells.Interior.ColorIndex = xlNone
ManualSheet.Cells.Font.Color = RGB(0, 0, 0)
lastRow = ManualSheet.Range("A" & Rows.Count).End(xlUp).Row
Col = "A"
For i = 2 To lastRow
Cells(i, Col) = Trim(Replace(Cells(i, Col), vbLf, "", 1, , vbTextCompare))
If InStr(1, Cells(i, Col), "about", vbTextCompare) <> 0 Then
Cells(i, Col) = Trim(Replace(Cells(i, Col), "about", "", 1, , vbTextCompare))
Cells(i, Col).Interior.Color = RGB(217, 151, 149)
End If
If InStr(1, Cells(i, Col), "after", vbTextCompare) <> 0 Then
Cells(i, Col) = Trim(Replace(Cells(i, Col), "after", "", 1, , vbTextCompare))
Cells(i, Col).Interior.Color = RGB(228, 109, 10)
End If
If InStr(1, Cells(i, Col), "before", vbTextCompare) <> 0 Then
Cells(i, Col) = Trim(Replace(Cells(i, Col), "before", "", 1, , vbTextCompare))
Cells(i, Col).Interior.Color = RGB(228, 109, 10)
End If
DateParts = Split(Cells(i, Col), "/", , vbTextCompare)
Cells(i, Col) = Format(Cells(i, Col), "dd/mm/yyyy")
Next i
Range("D:E").HorizontalAlignment = xlCenter
End Sub
The file is uploaded here. Date_format_macro_link
Please help!
Is this what you are trying? I have not added any error handling. I am assuming that you will not be deviating for the existing format of your data. If the format changes then you WILL have to introduce error handling.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim rng As Range
Dim MyAr() As String
Set ws = ThisWorkbook.Sheets("Data")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A2:A" & lRow)
With rng
'~~> Replace "After " in the entire column
.Replace What:="After ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
DoEvents
'~~> Replace "About " in the entire column
.Replace What:="About ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.NumberFormat = "dd/mm/yyyy"
End With
For i = 2 To lRow
'~~> Remove the End Spaces
.Range("A" & i).Value = Sid_SpecialAlt160(.Range("A" & i).Value)
'~~> Remove time after the space
If InStr(1, .Range("A" & i).Value, " ") Then _
.Range("A" & i).Formula = Split(.Range("A" & i).Value, " ")(0)
'~~> Convert date like text to date
.Range("A" & i).Formula = DateSerial(Split(.Range("A" & i).Value, "/")(2), _
Split(.Range("A" & i).Value, "/")(1), _
Split(.Range("A" & i).Value, "/")(0))
Next i
End With
End Sub
Public Function Sid_SpecialAlt160(s As String)
Dim counter As Long
If Len(s) > 0 Then
counter = Len(s)
While VBA.Mid(s, counter, 1) = " "
counter = counter - 1
Wend
Sid_SpecialAlt160 = VBA.Mid(s, 1, counter)
Else
Sid_SpecialAlt160 = s
End If
End Function
Screenshot
I'm trying to copy and paste a range, to create a 28 by 28 grid of numbers "rotating" the values so that each time the range is pasted into the next column, the range is moves down by one row and the last value "overflows" back to the top of the next row, I've got this far but am stumped on the overflow part (i' relative newbie to VBA)
Sub Test()
Dim oRange As Range
Set oRange = ActiveSheet.Range("A1:A28")
Dim i As Integer
For i = 1 To 28
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Next i
End Sub
Also I need to copy and paste values and formatting of the cells
Hope you guys can help
Thanks
Dan
Sub Test()
Dim oRange As Range
Dim startColumn As String
Dim rangeStart As Integer
Dim rangeEnd As Integer
Dim cellCount As Integer
Dim i As Integer
startColumn = "A"
rangeStart = 1
rangeEnd = 28
cellCount = rangeEnd - rangeStart + 1
For i = 1 To cellCount - 1
Set oRange = ActiveSheet.Range(startColumn & rangeStart & _
":" & startColumn & (rangeEnd - i))
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Set oRange = ActiveSheet.Range(startColumn & (rangeEnd - i + 1) & _
":" & startColumn & rangeEnd)
oRange.Copy
oRange.Offset((-1 * cellCount) + i, i).PasteSpecial xlPasteAll
Next i
End Sub
EDIT:
to insert a blanck row at index 'i':
Rows(i & ":" & i).Select
Selection.Insert Shift:=xlDown
to insert 5 rows at the top of the worksheet insert a row 5 times at index 1:
For i = 1 To 5
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Next