This is gonna be pretty specific.
I have an excel sheet with patient names and info in each row. The first row has the labels for each column. For instance, column a is PatientName. Im trying to export each row as their own word document with each cell in the row having its own line with a space/break between each. But I also want the label from row 1 to be with each specific row. Also make the first column aka PatientName the name for each document.
Ex.
Document Name: John Doe
Encounter Date
11-12-13
CC
Abdominal Pain
HPI
Mr. Doe is blah blah, and bunch of text
\Ex
Row #1 looks like:
PatientName/EncounterDate/CC/HPI
Row#2 which is where we wanna start looks like:
John Doe/11-12-13/Abdominal Pain/Mr. Doe blah blah
Each row has 27 cells
Thanks, and let me know if you need anymore info. VBA code.
Edit: This was the code I was using, but It makes each file into an Excel sheet and doesn't add row 1 with each row.
Sub SaveRowsAsCSV()
Dim wb As Excel.Workbook, wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim r As Long, c As Long
Set wsSource = ThisWorkbook.Worksheets("AmazingChartsEncounters")
Application.DisplayAlerts = False 'will overwrite existing files without asking
r = 1
Do Until Len(Trim(wsSource.Cells(r, 1).Value)) = 0
ThisWorkbook.Worksheets.Add ThisWorkbook.Worksheets(1)
Set wsTemp = ThisWorkbook.Worksheets(1)
For c = 2 To 27 'I didn't test it when I changed the 7 here to 27
wsTemp.Cells((c - 1) * 2 - 1, 1).Value = wsSource.Cells(r, c).Value
Next c
wsTemp.Move
Set wbNew = ActiveWorkbook
Set wsTemp = wbNew.Worksheets(1)
'wbNew.SaveAs wsSource.Cells(r, 1).Value & ".csv", xlCSV 'old way
wbNew.SaveAs "textfile" & r & ".csv", xlCSV 'new way
'you can try other file formats listed at http://msdn.microsoft.com/en-us/library/office/aa194915(v=office.10).aspx
wbNew.Close
ThisWorkbook.Activate
r = r + 1
Loop
Application.DisplayAlerts = True
End Sub
Related
I'm trying to figure out how i can make a offset based on the Active sheet number.
Example:
Right now in sheet number 2 in Cell "B1" I have a number set of 17000
On the same sheet at B8:B I have a column of numbers going down with certain values that I would like to add up to my base of 17000. Once I make a new sheet I want "A1" To have that value of the other 2 numbers added up.
I have a Code that "Fills in" The active sheet that I'm using.
But how could I make it that in each new sheet it will go 1 position down in column B8:B
So sheet 2 has the values that will be used.
New sheet nmbr 5 gets created which will need sheet 2 "B1" + "B8"
New sheet nmbr 6 gets created which will need sheet 2 "B1" + "B9"
New sheet nmbr 7 gets created which will need sheet 2 "B1" + "B10"
And so on and so on.
Sub KnopKlik()
Dim WB As Workbook
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim Active As Worksheet
Dim Titel1
Dim Titel2
Set WB = ActiveWorkbook
Set WS1 = WB.Sheets(1)
Set WS2 = WB.Sheets(2)
Set WS3 = WB.Sheets(3)
Set Active = WB.ActiveSheet
Set MC = Active.Range("B9")
Titel1 = WS2.Range("B1") 'Base number of 17000
Titel2 = WS2.Range("B8") 'Has to be added up to 17000 depending on sheet number
column1 = Sheets(3).Cells(1, 3).Value
Application.ScreenUpdating = False
'============================================================
Sheets(1).Visible = True ' Activate Sheets
Sheets(2).Visible = True
Sheets(3).Visible = True
Active.Select
ActiveSheet.Range("A1").Value = "Unit " & (Titel1 + Titel2)
'This is the line that is suppose to write the question i asked.
'=============================================================================
' Between these lines is a bunch of code i left out cause its irrelivant to the question.
'=============================================================================
Application.ScreenUpdating = True
Active.Select
Sheets(1).Visible = xlVeryHidden
Sheets(3).Visible = xlVeryHidden
Sheets(4).Visible = xlVeryHidden
MsgBox ("Done")
End Sub
I hope the question isn't to hard to understand. I got what i want exactly in my head but i find it hard to explain in English :P
Ok, try
Titel2 = WS2.cells(4 + activesheet.index,2)
Looking to generate a new sheet for each column in a workbook. (done, pasted below). Next step is to paste the value of Column A if a value is in column 'X'.
Name | Email | Course 101 | Course 203 |
John | john #| X | X |
Jane |Jane# | X | |
Result would be two sheets, (Course 101, Course 203) controlled with a 'Range' function during the sheet generation code.
Part I'm stuck on, is how to paste John's name on the Course 101 and Course 203 sheet and Jane only on the Course 101 sheet.
Here's the code that works for the sheet generation (I think found on here :) )
Sub AddSheets()
Dim cell As Excel.Range
Dim wsWithSheetNames As Excel.Worksheet
Dim wbToAddSheetsTo As Excel.Workbook
Set wsWithSheetNames = ActiveSheet
Set wbToAddSheetsTo = ActiveWorkbook
For Each cell In wsWithSheetNames.Range("A1:d1")
With wbToAddSheetsTo
.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = cell.Value
If Err.Number = 1004 Then
Debug.Print cell.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next cell
End Sub
The code above will work to insert the worksheets but it does not do anything after that. Based off the script above I wrote up something similar that does what you want but with slightly easier to understand variables and terms.
The code pasted below requires you to enter the main worksheet name or just set the main worksheet's name to "Main".
This code should be a lot easier to understand since it breaks the process up into 2 blocks.
Sub FillCourseWorksheets()
Dim wb As Workbook, cws As Worksheet, ws As Worksheet, found As Boolean
Dim crw As Long, rw As Long, col As Integer, wsName As String
Dim CheckString As String, student As String, lastRow As Long
Dim lastCol As Integer, courseName As String, resultRow As Long
'this code depends on the main sheet to have the headers in row 1
'----------------------------------------------------------
wsName = "Main" 'set this to the name of your main worksheet
'----------------------------------------------------------
'set up
Set wb = ThisWorkbook
'if you get an error here set the sheet name to main
Set cws = wb.Worksheets(wsName)
'use the .end to find the last column and row similar to CTRL + Right/Down
lastRow = cws.Range("A1").End(xlDown).Row
lastCol = cws.Range("A1").End(xlToRight).Column
'go through each column and add a worksheet if needed
For col = 3 To lastCol
CheckString = cws.Cells(1, col).Value
'check if the worksheet already exists
found = False
For Each ws In wb.Worksheets
If ws.Name = CheckString Then
found = True
Exit For
End If
Next ws
If found = False Then 'didnt find the sheet. Add it to the workbook
Set ws = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count)) 'add the worksheet
ws.Name = CheckString 'name it
ws.Range("A1").Value = "Name"
cws.Activate 'activate the main page after insert
End If
Next col
'all worksheets added go through columns again and add data to each worksheet
For col = 3 To lastCol
courseName = cws.Cells(1, col).Value
Set ws = wb.Worksheets(courseName) 'identify the worksheet to use
For checkrow = 2 To lastRow
If cws.Cells(checkrow, col).Value <> "" Then
student = cws.Range("A" & checkrow).Value
'set the resultrow and check if there is no data
If ws.Range("A2").Value = "" Then
resultRow = 2
Else
resultRow = ws.Range("A1").End(xlDown).Row + 1
End If
ws.Range("A" & resultRow).Value = student 'print out the student
End If
Next checkrow
Next col
MsgBox "done"
End Sub
Save your workbook before running this and let me know if you have any trouble.
Hello stackoverflow community,
I must confess I primarily code within MS Access and have very limited experience of MS Excel VBA.
My current objective is this, I have an "Expense Report" being sent to me with deductions, this report has many columns with different account names that may be populated or may be null.
My first step will be to start on the first record (Row 14; Column A-K contains personal info regarding the deduction) then skip to the first deduction account (deduction accounts start at column L and span to column DG) checking if each cell is null, if it is then keep moving right,If there is a value present, I need to copy it into an external workbook "Payroll Template" starting at row 2 (Column J for the deduction itself), as well as copy some personal info from the original row in the "Expense Report" related to that deduction (currRow: Column C,E,F from "Expense Report" to "Payroll Template" Columns B,C,D).
Then move to the right until the next cell contains a value, and repeat this process on a new row in the "Payroll Template". Once the last column (DG) has been executed I want to move to the next row (row 15) and start the process again all the way until the "LastRow" in my "Used Range".
I greatly appreciate any feedback, explanations, or links that may point me towards my goal. Thank you in advance for taking the time to read though this!
Current state of code:
`< Sub LoadIntoPayrollTemplate()
Dim rng As Range
Dim currRow As Integer
Dim UsedRng As Range
Dim LastRow As Long
Set UsedRng = ActiveSheet.UsedRange
currRow = 14
Set wb = ActiveWorkbook '"Expense Report"
Set wb2 = MyFilepath '"Payroll Template"
'Copied from another procedure, trying to use as reference
LastRow = rng(rng.Cells.Count).Row
Range("A14").Select
Do Until ActiveCell.Row = LastRow + 1
If (ActiveCell.Value) <> prev Then
currRow = currRow + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
With Worksheets("Collections")
lstRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng = .Range(.Cells(14, 12), Cells(lstRow, 111))
End With
End Sub>`
The following code may do what you are after:
Sub LoadIntoPayrollTemplate()
Dim currRowIn As Long
Dim currColIn As Long
Dim currRowOut As Long
Dim wb As Workbook
Dim wb2 As Workbook
Set wb = ActiveWorkbook '"Expense Report"
Set wb2 = Workbooks.Open(Filename:=MyFilepath & "\" & "Payroll Template.xlsx")
'or perhaps
'Set wb2 = Workbooks.Open(Filename:=wb.path & "\" & "Payroll Template.xlsx")
With wb.ActiveSheet
currRowOut = 1
For currRowIn = 14 To .UsedRange.Row + .UsedRange.Rows.Count - 1
For currColIn = 12 To 111
If Not IsEmpty(.Cells(currRowIn, currColIn)) Then
currRowOut = currRowOut + 1
'I'm not sure which worksheet you want to write the output to
'so I have just written it to the first one in Payroll Template
wb2.Worksheets(1).Cells(currRowOut, "J").Value = .Cells(currRowIn, currColIn).Value
wb2.Worksheets(1).Cells(currRowOut, "B").Value = .Cells(currRowIn, "C").Value
wb2.Worksheets(1).Cells(currRowOut, "C").Value = .Cells(currRowIn, "E").Value
wb2.Worksheets(1).Cells(currRowOut, "D").Value = .Cells(currRowIn, "F").Value
End If
Next
Next
End With
'Save updated Payroll Template
wb2.Save
End Sub
I have a file named vegetables_fruits and 4 other files : apple, banana, tomato, cucumber. In the file vegetables_fruits I have a Worksheet named List where I fold the names of all 4 files (ex., cell A2 = apple, cell A3 = banana, cell A4 = tomato, cell A5 = cucumber). In addition to the sheet List I have sheets banana, tomato and cucumber, but I don't have apple.
It's necessary to paste the column A from each of this 4 files to every sheet in the vegetables_fruits (ex., from file apple it's necessary to copy column A to file "vegetables_fruits" to sheet "banane" ; from file "banana" it's necessary to copy column A to file vegetables_fruits to sheet tomato etc.) Thank you very much for your help!
P.S. It needs to create a For, but I don't know how I can decribe all of this conditions.
Sub CopyPaste()
Dim r As Variant
Dim a As Variant
Dim b As Integer
Dim nbcells As Integer
Dim ws As Worksheet
Worksheets("List").Activate
nbcells = Application.WorksheetFunction.CountA(Range("A2:A" & Range("A65536").End(xlUp).Row))
' === Create a new sheet ===
For r = 2 To nbcells
Sheets.Add After:=Sheets(Sheets.Count - 1)
Worksheets(r).Name = Worksheets("List").Cells(r + 1, 1).Value
Next r
' === DATA ===
For Each ws In Sheets
If ws.Name Like "*.xls*" Then
For a = 2 To nbcells
Windows(a).Activate
Range("B:B").SpecialCells(2).Copy
Workbooks("vegetables_fruits.xlsm").Activate
b = a + 1
If ws.Name = Worksheets("List").Cells(b, 1).Value Then
ws.Select
Range("A2").Select
ActiveSheet.Paste
End If
Next a
End If
Next
End Sub
Maria - Reading your question, I think the additional logic you need is as follows:
Assume all workbooks are open, and have the appropriate name.
Loop through all of the workbooks.
If I find a workbook with one of my defined names, then copy Column A from (some sheet) in that workbook
Paste this into the master workbook, on the sheet with the corresponding name.
For my example, you would need to add these variables in the section where the variables are declared.
Dim fromWS As Worksheet, toWS As Worksheet
Dim wb As Workbook, myWB As Workbook
Early in the code, near the top, you will need this line of code.
Set myWB = ActiveWorkbook
Later in the code, this Loop and Case statements will accomplish the above logic ...
For Each wb In Workbooks
Select Case wb.Name
Case "apple"
Set fromWS = wb.Worksheets("Sheet1") '<~~ put your sheet name here
Set toWS = myWB.Worksheets("apple")
Case "banana"
Set fromWS = wb.Worksheets("Sheet1") '<~~ put your sheet name here
Set toWS = myWB.Worksheets("banana")
Case "tomato"
Set fromWS = wb.Worksheets("Sheet1") '<~~ put your sheet name here
Set toWS = myWB.Worksheets("tomato")
Case "cucumber"
Set fromWS = wb.Worksheets("Sheet1") '<~~ put your sheet name here
Set toWS = myWB.Worksheets("cucumber")
Case Else
End Select
fromWS.Range("A:A").Copy toWS.Range("A:A")
Next wb
You talk about there not being an "apple" sheet. This is a nuance you may need to build exception logic for. (e.g. just omit that case in the above loop)
I have tried searching the internet for various answers to this question but cannot find the right answer. I have an Excel Workbook with worksheets represent each day of the month. In each of these sheets the format is the same (except on Saturdays and Sundays) and the sheets contain call stats. It is presented in the following format:
00:00 00:30 0 4 6 3 4 8 0 1 0 0 0
00:00 00:30 0 0 2 7 4 1 0 0 3 3 0
00:00 00:30 7 0 7 5 2 8 6 1 7 9 0
I need to copy this data into 1 single sheet that lists all the data. Basically it appends the new data on to the bottom of the old data. So it will be one big list.
How can this be done? All I can see is how to produce a total from multiple data by adding all the values together. I just need to list the data as one big list.
MASSIVE EDIT:
As with last chat with Iain, the correct parameters have been set. I have removed the last few code snippets as they are quite not right. If anyone is still interested, please check the edit history.
Hopefully, this is the final edit. ;)
So, the correct conditions needed are:
Month name in sheet. We used an Input Box for this.
We check for number of rows. There are three conditions: 157 rows total, 41 rows total, and all else.
The following subroutine will do the trick.
Sub BlackwoodTransfer()
Dim Summ As Worksheet, Ws As Worksheet
Dim ShName As String
Dim nRow As Long
Set Summ = ThisWorkbook.Sheets("Summary")
ShName = InputBox("Enter month for Call Flow in mmmm format (ie. November, etc.):") & " Call Flow"
'Returns November Call Flow. This means it will target every sheet that has November Call Flow in its name.
Application.ScreenUpdating = False
For Each Ws In ThisWorkbook.Worksheets
If InStr(1, Ws.Name, ShName) > 0 Then
'Starting from first character of the sheet's name, if it has November, then...
nRow = Summ.Cells(Rows.Count, 1).End(xlUp).Row + 1
'... get the next empty row of the Summary sheet...
Select Case Ws.Cells(Rows.Count, 1).End(xlUp).Row
'... check how many rows this qualified sheet has...
Case 157
'... if there are 157 rows total...
Ws.Range(Cells(57,1),Cells(104,13)).Copy
'... copy Rows 57 to 104, 13 columns wide...
Summ.Range("A" & nRow).PasteSpecial xlPasteAll
'... and paste to next empty row in Summary sheet.
Case 41
Ws.Range(Cells(23,1),Cells(126,13)).Copy
Summ.Range("A" & nRow).PasteSpecial xlPasteAll
Case Else
Ws.Range(Cells(23,1),Cells(30,13)).Copy
Summ.Range("A" & nRow).PasteSpecial xlPasteAll
End Select
End If
Next Ws
Application.ScreenUpdating = True
End Sub
#Iain: Check out the comments and cross reference them with the MSDN database. That should explain what each function/method is doing exactly. Hope this helps!
Sub CombineSheets()
Dim ws As Worksheet, wsCombine As Worksheet
Dim rg As Range
Dim RowCombine As Integer
Set wsCombine = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(1))
wsCombine.Name = "Combine"
RowCombine = 1
For Each ws In ThisWorkbook.Worksheets
If ws.Index <> 1 Then
Set rg = ws.Cells(1, 1).CurrentRegion
rg.Copy wsCombine.Cells(RowCombine, 2)
wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)) = ws.Name
RowCombine = RowCombine + rg.Rows.Count
End If
Next
wsCombine.Cells(1, 1).EntireColumn.AutoFit
Set rg = Nothing
Set wsCombine = Nothing
End Sub
Create a worksheet "Summary" which is to contain all the merged data.
Open ThisWorkBook (simply press ALT+F11 in your excel workbook. A new window will open. Your worksheet name will be visible on the left hand side. Keep expanding till you see ThisWorkBook)
Double click ThisWorkBook and add the following code in it:
Sub SummurizeSheets()
Dim ws As Worksheet
Application.Screenupdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" Then
ws.Range("F46:O47").Copy
ActiveSheet.Paste Range("A65536").End(xlUp).Offset(1, 0)
End If
Next ws
End Sub
Sub AddToMaster()
'this macro goes IN the master workbook
Dim wsMaster As Worksheet, wbDATA As Workbook
Dim NextRow As Long, LastRow As Long
Dim FileName As String
Dim FolderPath As String
Dim n As Long
Dim i
Set wsMaster = ThisWorkbook.Sheets("Sheet1")
'Specify the folder path
FolderPath = "D:\work\"
'specifying file name
FileName = Dir(FolderPath & "*.xls*")
Do While FileName <> ""
NextRow = wsMaster.Range("A" & Rows.Count).End(xlUp).Row + 1
Set wbDATA = Workbooks.Open(FolderPath & FileName)
With wbDATA.Sheets("product_details")
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
' If LastRow > 5 Then
For i = 2 To LastRow
.Range("A2:j" & i).Copy
wsMaster.Range("A" & NextRow).PasteSpecial xlPasteValues
'Set NextRow = NextRow
Next i
End With
FileName = Dir()
Loop
wbDATA.Close False
End Sub