Excel script - copy to keyword vertically, post horizontally

Scripting Forums Code Exchange
#1

Here’s an excel script I wrote to copy a vertical group of cells ending in a keyword, and then pasting these cells horizontally on the next page.

The only thing I’d love to add on eventually is a dialog box that pops up at the beginning which asks you what you’d like the delineating keyword to be. For now the keyword is “Map” but of course can be changed to whatever you like. The default number of entires is 80 (this can be changed in the script too)

Eg. (keyword is Map)(number of total entries to cut and paste is 80)

John Doe
1111 Doe Street
123-4567
Map

Sally Anne
1111 Anne Street
765-4321
Map

Becomes:

John Doe 1111 Doe Street 123-4567 Map
Sally Anne 1111 Anne Street 765-4321 Map



tell application "Microsoft Excel"
	activate object worksheet "Sheet1"
	
	(* Make sure your list is on sheet 1 and you have a blank sheet 2 created *)
	(* default search word is Map and default number of entires is 80 - change below if you like *)
	
	set mycol1 to 1
	set myrow1 to 1
	(* Change the word Map below if you want a different keyword to search for *)
	set nextmap to (find (range "A:A" of worksheet "Sheet1") what "Map")
	get address nextmap
	set mycol2 to first column index of nextmap
	set myrow2 to first row index of nextmap
	
	set rownumx to 1
	(* increase rownumx final value below if you have more or fewer entries *)
	repeat with rownumx from 1 to 80
		set firstcel to (get address of cell mycol1 of row myrow1 of active sheet)
		set lastcel to (get address of cell mycol2 of row myrow2 of active sheet)
		set myrange to range (firstcel & ":" & lastcel)
		select myrange
		copy range myrange
		paste special cell 1 of row rownumx of sheet 2 with transpose
		
		set rownumbx to rownumx + 1
		set myrow1 to myrow2 + 1
		set nextmap to (find next (range "A:A" of worksheet "Sheet1") after nextmap)
		get address nextmap
		set mycol2 to first column index of nextmap
		set myrow2 to first row index of nextmap
		tell application "System Events" to set the clipboard to ""
		
	end repeat
end tell

(*
next version would include a dialog box at the beginning that asks the user for the keyword which deliniates vertical groupings
also nice if it just applied to selection and not necessary to set final rownumx value manually
*)

AppleScript: 2.1.1
Browser: Safari 531.21.10
Operating System: Mac OS X (10.6)

#2

This uses a dialog box to get the keyword (“Map” in your example). Entering nothing uses a blank cell as the key.
As written, it will copy all the data to Sheet2, but the maxLImit can be set in the indicated place.

tell application "Microsoft Excel"
	set myBook to workbook (name of active workbook)
	set sourceSheet to get worksheet "Sheet1" of myBook
	set destinationSheet to get worksheet "Sheet2" of myBook
	set maxLimit to 65537 -- set to theoretical maximum.
	
	-- user inputs dividing text "" for blank cell as divider
	set delimitValue to text returned of (display dialog "Enter the delimiting value." default answer "")
	
	-- define working ranges
	set screen updating to false
	tell column 1 of sourceSheet
		set value of (get offset (get end (cell -1 of column 1) direction toward the top) row offset 1) to delimitValue
		set sourceRange to get resize row size (first row index of (get end (cell -1 of column 1) direction toward the top))
	end tell
	
	-- change marker to "" (change "" to space if needed)
	if delimitValue ≠ "" then
		replace sourceRange what "" replacement " " look at whole without match case
		replace sourceRange what delimitValue replacement "" look at whole without match case
	end if
	
	-- use special cells to get each clump of data
	activate object sourceSheet
	set filledCells to (get special cells sourceRange type cell type constants)
	
	-- loop through areas of special cells
	set counter to 0
	repeat with oneArea in (get areas of filledCells)
		-- copy to destination
		set destinationRange to (get resize (get offset (get end (cell -1 of column 1 of destinationSheet) direction toward the top) row offset 1) column size (count of rows of oneArea))
		copy range oneArea
		paste special destinationRange what paste all with transpose
		set counter to counter + 1
		if counter ≥ maxLimit then exit repeat
	end repeat
	
	-- restore marking values
	set sourceRange to get resize sourceRange row size ((count of rows of sourceRange) - 1)
	if delimitValue ≠ "" then
		replace sourceRange what "" replacement delimitValue look at whole without match case
		replace sourceRange what " " replacement "" look at whole without match case
	end if
	
	-- finish up
	activate object destinationSheet
	set cut copy mode to false
	set screen updating to true
end tell