I am new to VBA and I want to do the following:
I am inputting data for different materials, I will add new materials daily, a new column for each new material.
What I want to do then, is select ONLY the latest column entry, and export that as a .txt file.
I have managed to export the entire worksheet, but have not yet managed to find how to export only the latest "entry" of the worksheet.
This code based on example publicated John_w at https://www.mrexcel.com/board/threads/vba-to-export-a-specific-worksheet-to-txt-file.754163/#post-3703300 and adapted to your case:
Option Explicit
Public Sub SaveLastColumn()
Dim rng As Range
Set rng = Worksheets(1).UsedRange ' get an area with data on the sheet
Set rng = rng.Columns(rng.Columns.Count) ' get the last column inside rng
Open "File.txt" For Output As #1 ' open text file for output
If rng.Cells.Count > 1 Then ' rng can contains 1 or many cells
Dim arr As Variant ' in case of many cells
arr = Application.Transpose(rng.Value)
Print #1, Join(arr, vbCrLf) ' write many values to file
Else ' in case of 1 cell
Print #1, rng.Value ' write single value to file
End If
Close #1
End Sub
Related
I'm using the following code (see below) to copy certain rows from worksheet A to worksheet B. There are only values in columns A till N, but after copying to worksheet B, excel changes the document printing range to A till column XFD, so while printing the copied worksheet B, there are like +100 blank pages created. I have no clue what causes the problem, I've changed the scrollArea of the worksheet, but still no change in the created print range. Is it possible to lock the print range using VBA to $A:$N?
Copying code included below.
Sub Samenvattend()
'
' Samenvattend Macro
'
' Sneltoets: Ctrl+Shift+S
'
If ActiveSheet.Name <> "gedetailleerde meetstaat" Then
MsgBox "Deze macro kan alleen in het werkblad 'gedetailleerde meetstaat' worden toegepast"
Else
Dim a As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("gedetailleerde meetstaat")
Set Target = ActiveWorkbook.Worksheets("samenvattende meetstaat")
j = 2 ' Start copying to row 2 in target sheet
For Each a In Source.Range("A2:A10000") ' Do 10000 rows
If a <> "" Then
Source.Rows(a.Row).Copy Target.Rows(j)
Target.Rows(j).Value = Source.Rows(a.Row).Value
Target.Cells(j, 13).FormulaR1C1 = "=RC[-4]*RC[-1]"
j = j + 1
End If
Next a
End If
End Sub
Thanks :)
I would like to copy a range of values from one worksheet into a specified range of another worksheet whereas values always come from the previous worksheet (in the worksheet row), even after duplicating the worksheet. I'm using the following to copy values from one worksheet to the other, which seems to work:
Sub Copy_ultimo_stock()
'copy values between two periods
Worksheets("Period2").Range("test3").Value = Worksheets("Period1").Range("test2").Value
End Sub
I had to give the range of cells a name (test2 and test3), because the macro wouldn't work if I use the actual cell range like "R10:S11". In the future however, I would just like to use the cell range as "R10:S11".
My actual problem however is the following. If I duplicate my worksheets in the future (for future periods), I want that I always copy the cell range from the previous worksheet. The way I have done it now, if I copy the worksheet period2, and call it maybe period6, it will still copy values from period1 worksheet. However, I would like that the current worksheet "n" will copy values from the range in worksheet "n-1".
I have found a somewhat similar approach that could help, but I couldn't combine both macros into one. That approach is here:
Function PrevSheet(rCell As Range)
Application.Volatile
Dim i As Integer
i = rCell.Cells(1).Parent.Index
PrevSheet = Sheets(i - 1).Range(rCell.Address)
End Function
EDIT
So you requirement is a macro that imports from "the previous sheet", so that when you click the button, the subroutine first fetches the previous from the current and accordingly fetches the values.
We will suppose that all Worksheets are named like "periodx", where x is an integer identifying the period. when we create a new worksheet copy, we need first to rename the new worksheet in the form "periodx" and then click on the button to fetch the values from the sheet "periody" where y = x-1.
Just replace your button handler Copy_ultimo_stock() with this one:
Sub Copy_ultimo_stock()
Dim wsCur As Worksheet, wsPrev As Worksheet
Set wsCur = ActiveSheet
' We will suppose that all Worksheets are named like "periodx"
' where x is an integer identifying the period
On Error Resume Next ' try fetching the previous ws as "periody" where y = x-1
Dim x As Integer: x = CInt(Mid(wsCur.Name, Len("period") + 1))
Set wsPrev = ThisWorkbook.Sheets("period" & (x - 1))
If Err.Number <> 0 Then
msgBox "Could not find the previous worksheet, Please check Worksheet names"
Exit Sub
End If
On Error GoTo 0
' Now we copy the previous values. You can customize the ranges if the design changes
wsCur.Range("D2:L8").Value = wsPrev.Range("D10:L16").Value
End Sub
Moreover, you can automate the generation of a new period worksheet by adding another button, say "Generate Next Period", that will create the new ws and give it the appropriate name. This will save the user the task of copying the sheet and renaming it. The code for the new button will be like this:
Sub create_next_period()
Dim wsCur As Worksheet, wsNext As Worksheet
Set wsCur = ActiveSheet
On Error Resume Next
Dim x As Integer: x = CInt(Mid(wsCur.Name, Len("period") + 1))
If Err.Number <> 0 Then
msgBox "Please check Worksheet name. It should be named periodx"
Exit Sub
End If
Set wsNext = ThisWorkbook.Sheets("period" & (x + 1))
If Err.Number = 0 Then
msgBox "The worksheet " & wsNext.Name & " already exists"
Exit Sub
Else
Err.Clear
wsCur.Copy After:=Worksheets(Worksheets.Count)
Set wsNext = Worksheets(Worksheets.Count)
wsNext.Name = "period" & (x + 1)
wsNext.Activate
Call Copy_ultimo_stock
End If
End Sub
When you name your cells do:
Range("whatever").name="Sheet!Name"
and not just
Range("whatever").name="Name"
==> this way you can gave the same named range on several sheets without any problem
Hope this helps.
However I wouldn't advice using too much named ranges...
I'm not really great at coding so as much help as possible would be incredible. Basically here's what I want to do.
Export CSV from Website (No code required)
Open CSV in Excel (No code required)
Automatically remove rows that have a blank cell in certain column (Already coded)
Copy specific columns (ignoring header rows) to another workbook in specific order.
Column order is as follows: (S1 = Open CSV || S2 = New Workbook)
S1.V = S2.A
S1.B = S2.D
S1.F = S2.V
S1.H = S2.X
S1.I = S2.J
S1.L = S2.B
Step 3's code:
Columns("V:V").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
There is a lot to consider when doing what you require, I have made some assumptions that you will need to code for if they are incorrect: -
The destination already exists
The destination has headers on row 1 but no content
The destination is simply the first sheet in the destination workbook
The source header row is row 1
Sample code: -
Public Sub Sample()
Dim StrDestPath As String
Dim WkBk_Dest As Workbook
Dim WkBk_Src As Workbook
Dim WkSht_Dest As Worksheet
Dim WkSht_Src As Worksheet
'A reference to the destination
StrDestPath = "C:\Users\Gary\Desktop\Destination.xlsx"
'Connect to the source
Set WkBk_Src = ThisWorkbook
Set WkSht_Src = WkBk_Src.Worksheets(1)
'See if the destination is open already
For Each WkBk_Dest In Application.Workbooks
If WkBk_Dest.FullName = StrDestPath Then Exit For
Next
'If it wasn't then open it
If WkBk_Dest Is Nothing Then
Set WkBk_Dest = Application.Workbooks.Open(StrDestPath)
End If
'Connect to the destination
Set WkSht_Dest = WkBk_Dest.Worksheets(1)
'Per column mapping - Copy everythng from row 2 (assuming headers are on row 1 down to the last populated cell in that column
'and paste it into the required column in the destination
WkSht_Src.Range("V2:" & WkSht_Src.Range("V2").End(xlDown).Address).Copy WkSht_Dest.Range("A2")
WkSht_Src.Range("B2:" & WkSht_Src.Range("B2").End(xlDown).Address).Copy WkSht_Dest.Range("D2")
WkSht_Src.Range("F2:" & WkSht_Src.Range("F2").End(xlDown).Address).Copy WkSht_Dest.Range("V2")
WkSht_Src.Range("H2:" & WkSht_Src.Range("H2").End(xlDown).Address).Copy WkSht_Dest.Range("X2")
WkSht_Src.Range("I2:" & WkSht_Src.Range("I2").End(xlDown).Address).Copy WkSht_Dest.Range("J2")
WkSht_Src.Range("L2:" & WkSht_Src.Range("L2").End(xlDown).Address).Copy WkSht_Dest.Range("B2")
'Disconnect from destination worksheet
Set WkSht_Dest = Nothing
'save changes
WkBk_Dest.Save
'disconnect from destination workbook
Set WkBk_Dest = Nothing
'Disconnect from source
Set WkSht_Src = Nothing
Set WkBk_Src = Nothing
End Sub
I have also assumed the source to be the workbook I was coding in, this won't be possible in a CSV file so you might want to open it in the same way the destination is checked for and then opened, you also may want to add a flag to close them when done if they were not opened to begin with.
Finally, if the destination already has data use the .end function as shown in the sample to get the the last row.
since you're working from CSV file, you don't have formats to carry along
therefore simple values pasting is what you need
try this
Option Explicit
Sub CopyColumnsToAnotherWB(sourceWS As Worksheet, targetWs As Worksheet, sourceCols As String, targetCols As String)
Dim sourceColsArr As Variant, targetColsArr As Variant
Dim iCol As Long, nCols As Long
sourceColsArr = Split(Application.WorksheetFunction.Trim(sourceCols), ",") '<--| make array out of string with delimiter
targetColsArr = Split(Application.WorksheetFunction.Trim(targetCols), ",") '<--| make array out of string with delimiter
nCols = UBound(sourceColsArr) '<--| count columns number to copy/paste
If nCols <> UBound(targetColsArr) Then Exit Sub '<--| exit if the two columns list haven't the same number of columns
With sourceWS
For iCol = 0 To nCols '<--|loop through source sheet columns
With .Cells(1, sourceColsArr(iCol)).Resize(.Cells(.Rows.Count, sourceColsArr(iCol)).End(xlUp).Row)
targetWs.Columns(targetColsArr(iCol)).Resize(.Rows.Count).value = .value '<--|paste values to corresponding target sheet column
End With
Next iCol
End With
End Sub
which you can exploit as follows
Option Explicit
Sub main()
Dim sourceCols As String, targetCols As String
sourceCols = "V,B,F,H,I,L"
targetCols = "A,D,V,X,J,B"
CopyColumnsToAnotherWB ActiveWorkbook.ActiveSheet, Workbooks("columntest").Worksheets("test"), sourceCols, targetCols
End Sub
just change ActiveWorkbook.ActiveSheet and Workbooks("columntest").Worksheets("test") to your actual source and target workbooks and worksheets
I am very new to VBA and there is a task I would like to automate and don't know where to start. I have a data set that looks like below.
Sample Data
What I'm trying to do is loop through column A and if it has something in it (will always be an email) select all rows until there is something in column A again. Copy and paste into new tab. So row 2-5 would copy and paste into a new tab. Then row 6-9 into a different new tab. Also row 1 would copy to each tab as well. I haven't been able to find code to help with this specific need and any help would be greatly appreciated.
I found this code and started modifying it but, it's nowhere close to what I need or working for that matter.
Sub split()
Dim rng As Range
Dim row As Range
Set rng = Range("A:A")
For Each row In rng
'test if cell is empty
If row.Value <> "" Then
'write to adjacent cell
row.Select
row.Copy
Worksheets("Sheet2").Activate
Range("A2").Select
row.PasteSpecial
Worksheets("Sheet1").Activate
End If
Next
End Sub
This code should provide what you need:
Sub Split()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets(1) 'change sheet index or use Worksheets("Sheet1") method to use exact name
Dim rngBegin As Range
Dim rngEnd As Range
With ws
Dim rngHeader As Range
Set rngHeader = .Range("A1:H1") 'to copy headers over each time
Dim lRowFinal As Long
lRowFinal = .Range("C" & .Rows.Count).End(xlUp).Row 'assumes eventually last row of needed data will have an address1
Set rngEnd = .Range("A1") ' to begin loop
Set rngBegin = rngEnd.End(xlDown) 'to begin loop
Do
Set rngEnd = rngBegin.End(xlDown).Offset(-1)
Dim wsNew As Worksheet
Set wsNew = Worksheets.Add(After:=wb.Sheets(.Index))'always after current sheet, change as needed
.Range(.Cells(rngBegin.Row, 1), .Cells(rngEnd.Row, 8)).Copy wsNew.Range("A2")
wsNew.Range("A1:H1").Value = rngHeader.Value
Set rngBegin = rngEnd.End(xlDown)
Loop Until rngBegin.Row >= lRowFinal
End With
End Sub
Try to break your process into steps and determine rules on how to proceed. Then write out some pseudo-code (code like logic) to make sure it all makes sense.
You need some sort of loop, since you are going to treat each
group of rows in the same way.
You need some code that determines what cells are contained in each block
Code to take a block (given by step 2) and paste it into a new tab.
Your Pseudo Code might look like this:
' This is the main function that runs the whole routine
Sub Main()
Set headerRg = GetHeaderRg()
Do Until IsAtTheEnd(startRow) = True
Set oneBlock = GetNextBlock(startRow)
Call ProcessBlock(oneBlock)
startRow = startRow + oneBlock.Rows.Count
Loop
End Sub
' This function returns the header range to insert into the top
Function GetHeaderRg() As Range
' Write some code here that returns the header range
End Function
' This function determines whether we are at the end of our data
Function IsAtTheEnd(current_row as Long) as Boolean
' Write some code here that determines whether we have hit the end of our data
'(probably checks the first column to see if there is data)
End Function
' This function takes the startRow of a block and returns the whole block of Rows
Function GetNextBlock(startRow) As Range
' Write some code that returns the whole range you want to copy
End Function
' This sub takes a range to be processed and a header to print and prints
' it into a new tab
Sub ProcessBlock(BlockRg As Range, headerRg as Range)
Set targetSheet = thisWorkbook.Sheets.Add()
' Write some code that pastes the headerRg and BlockRg where you want it
End Sub
If you start to have more specific questions about syntax etc, we will be happy to help here!
Right now I have a master excel workbook that employees use for data entry. Each of them downloads a copy to their desktops and then marks their progress on various entries by entering an "x" in a comlun next to the data they've finished. Each product has its own row with its respective data listed across that row. The master workbook is filled out throughout the quarter with new data for the products as it becomes available, which is currently updated on each individuals workbook by use of a macro that simply copies the range where the data is (see code below).
Sub GetDataFromClosedWorkbook()
'Created by XXXX 5/2/2014
Application.ScreenUpdating = False ' turn off the screen updating
Dim wb As Workbook
Set wb = Workbooks.Open("LOCATION OF FILE", True, True)
' open the source workbook, read only
With ThisWorkbook.Worksheets("1")
' read data from the source workbook: (Left of (=) is paste # destination, right of it is copy)
.Range("F8:K25").Value = wb.Worksheets("1").Range("F8:K25").Value
End With
With ThisWorkbook.Worksheets("2")
' read data from the source workbook: (Left of (=) is paste # destination, right of it is copy)
.Range("V5:Z359").Value = wb.Worksheets("2").Range("V5:Z359").Value
End With
wb.Close False ' close the source workbook without saving any changes
Set wb = Nothing ' free memory
Application.ScreenUpdating = True ' turn on the screen updating
End Sub
The problem I'm having is this: every once and a while, I'll need to add a new product, which adds a row on the master (this is opposed to adding data, which is just added across the row). Sometimes this row is at the end, sometimes it's in the middle. As you can see from the code below, my VBA currently can't handle this row change as it is just copy/pasting from a predefined range. Each users's workbook does not pick up on this change in row # and thus the data in the colums becomes associated with the wrong rows. Normally, you could just copy the entire sheet and problem solved. The issue I have is that each user needs to be able to record their own process in their own workbook next to their data. Is there a way to code this so that a new row on the master sheet will be accounted for and added to all the others without erasing/moving the marks made by each user? I've been trying to find a way to make it "insert" rows if they're new in the master, as this would preserve the data, but can't figure it out. Also, due to security on the server at work- linking workbooks, etc is not an option. Does anyone have any thoughts on this?
One way to approach this problem would be using the Scripting.Dictionary Object. You could create a dictionary for both the target and source identifiers and compare those. I suppose you don't really need the Key-Value pair to achieve this, but hopefully this gets you on the right track!
Sub Main()
Dim source As Worksheet
Dim target As Worksheet
Dim dictSource As Object
Dim dictTarget As Object
Dim rng As Range
Dim i As Integer
Dim j As Integer
Dim idSource As String
Dim idTarget As String
Dim offset As Integer
Set source = ThisWorkbook.Sheets(2)
Set target = ThisWorkbook.Sheets(1)
offset = 9 'My data starts at row 10, so the offset will be 9
Set rng = source.Range("A10:A" & source.Cells(source.Rows.Count, "A").End(xlUp).Row)
Set dictSource = CreateObject("Scripting.Dictionary")
For Each cell In rng
dictSource.Add Key:=cell.Value, Item:=cell.Row
Next
Set rng = target.Range("A10:A" & target.Cells(target.Rows.Count, "A").End(xlUp).Row)
Set dictTarget = CreateObject("Scripting.Dictionary")
For Each cell In rng
dictTarget.Add Key:=cell.Value, Item:=cell.Row
Next
i = 1
j = source.Range("A10:A" & source.Cells(source.Rows.Count, "A").End(xlUp).Row).Rows.Count
Do While i <= j
Retry:
idSource = source.Cells(i + offset, 1).Value
idTarget = target.Cells(i + offset, 1).Value
If Not (dictSource.Exists(idTarget)) And idTarget <> "" Then
'Delete unwanted rows
target.Cells(i + offset, 1).EntireRow.Delete
GoTo Retry
End If
If dictTarget.Exists(idSource) Then
'The identifier was found so we can update the values here...
dictTarget.Remove (idSource)
ElseIf idSource <> "" Then
'The identifier wasn't found so we can insert a row
target.Cells(i + offset, 1).EntireRow.Insert
'And you're ready to copy the values over
target.Cells(i + offset, 1).Value = idSource
End If
i = i + 1
Loop
Set dictSource = Nothing
Set dictTarget = Nothing
End Sub