Need some help coding in VBA Excel.
So currently, I have 100+ tables and have to manually input all the data to each table from many separate Excel file from each region.
You can view the table image here: https://i.stack.imgur.com/ftLdE.png
My current code still depends on targeting a range of cells to copy which is not feasible considering if there is a change in the rows/columns.
Is there anyway to collectively get all the data from each region's Excel file and insert it?
Or is it possible to target a header or a table name so that it can fill in automatically?
Pardon me if the solution is so simple and have been asked before.
Thank you so much for the help.
Sub Extract()
Dim x As Workbook
Dim y As Workbook
Dim OpenSource As String
Dim OpenTarget As String
OpenSource = Application.GetOpenFilename("File Type, *.xlsm")
If OpenSource = "False" Then Exit Sub
OpenTarget = Application.GetOpenFilename("File Type, *.xlsm")
If OpenTarget = "False" Then Exit Sub
'## Open both workbooks first:
Set x = Workbooks.Open(OpenSource) 'Source File 'thisworkbook can implement here?
Set y = Workbooks.Open(OpenTarget) 'Destination File
'Now, transfer values from x to y:
y.Sheets("Data").Range("C16:N16").Value = x.Sheets("Data").Range("C19:N19").Value
y.Sheets("Data").Range("C34:N34").Value = x.Sheets("Data").Range("C37:N37").Value
y.Sheets("Data").Range("C52:N52").Value = x.Sheets("Data").Range("C55:N55").Value
y.Sheets("Data").Range("C70:N70").Value = x.Sheets("Data").Range("C73:N73").Value
y.Sheets("Data").Range("C124:N124").Value = x.Sheets("Data").Range("C127:N127").Value
y.Sheets("Data").Range("C286:N286").Value = x.Sheets("Data").Range("C289:N289").Value
y.Sheets("Data").Range("R88:AC88").Value = x.Sheets("Data").Range("R91:AC91").Value
y.Sheets("Data").Range("R106:AC106").Value = x.Sheets("Data").Range("R109:AC109").Value
y.Sheets("Data").Range("R142:AC142").Value = x.Sheets("Data").Range("R145:AC145").Value
y.Sheets("Data").Range("R160:AC160").Value = x.Sheets("Data").Range("R163:AC163").Value
y.Sheets("Data").Range("R178:AC178").Value = x.Sheets("Data").Range("R181:AC181").Value
y.Sheets("Data").Range("R196:AC196").Value = x.Sheets("Data").Range("R199:AC199").Value
y.Sheets("Data").Range("R214:AC214").Value = x.Sheets("Data").Range("R217:AC217").Value
y.Sheets("Data").Range("R232:AC232").Value = x.Sheets("Data").Range("R235:AC235").Value
y.Sheets("Data").Range("R250:AC250").Value = x.Sheets("Data").Range("R253:AC253").Value
y.Sheets("Data").Range("R268:AC268").Value = x.Sheets("Data").Range("R271:AC271").Value
y.Sheets("Data").Range("AG88:AR88").Value = x.Sheets("Data").Range("AG91:AR91").Value
y.Sheets("Data").Range("AG106:AR106").Value = x.Sheets("Data").Range("A109:AR109").Value
y.Sheets("Data").Range("AG142:AR142").Value = x.Sheets("Data").Range("AG145:AR145").Value
y.Sheets("Data").Range("AG160:AR160").Value = x.Sheets("Data").Range("AG163:AR163").Value
y.Sheets("Data").Range("AG178:AR178").Value = x.Sheets("Data").Range("AG181:AR181").Value
y.Sheets("Data").Range("AG196:AR196").Value = x.Sheets("Data").Range("AG199:AR199").Value
y.Sheets("Data").Range("AG214:AR214").Value = x.Sheets("Data").Range("AG217:AR217").Value
y.Sheets("Data").Range("AG232:AR232").Value = x.Sheets("Data").Range("AG235:AR235").Value
y.Sheets("Data").Range("AG250:AR250").Value = x.Sheets("Data").Range("AG253:AR253").Value
y.Sheets("Data").Range("AG268:AR268").Value = x.Sheets("Data").Range("AG271:AR271").Value
MsgBox ("Done")
End Sub
Sure. as long as you know the starting point, you can dynamically count and copy rows, see modification to code below:
x.Sheets("Data").Range("C16:N" & Cells(Rows.Count, 14).End(xlUp).Row).Copy Destination:=y.Sheets("Data").Range("C19")
where i have put Cells(Rows.Count,14), the 14 relates to column N.
Apply the same logic to the rest and you should be fine! let me know how this works as i have not tested it :)
I think we have the Destination and Source the wrong way around as well.
How do I put the code in reverse? E.g. The source should be from row C19:N19 of the source file and to be copied to row C14:N14 of the destination file.
Sub Extract()
Dim x As Workbook
Dim y As Workbook
Dim OpenSource As String
Dim OpenTarget As String
OpenSource = Application.GetOpenFilename("File Type, *.xlsm")
If OpenSource = "False" Then Exit Sub
OpenTarget = Application.GetOpenFilename("File Type, *.xlsm")
If OpenTarget = "False" Then Exit Sub
Set x = Workbooks.Open(OpenSource) 'Source File
Set y = Workbooks.Open(OpenTarget) 'Destination File
x.Sheets("Data").Range("C14:N" & Cells(Rows.Count, 14).End(xlUp).Row).Copy Destination:=y.Sheets("Data").Range("C19")
MsgBox ("Done")
End Sub
Related
I'm using three Workbooks. My Current workbook, The database workbook (DB_Wkb), the Document to change ( Doc_Wkb) and my current macro file.
I'm using vLookup to compare the ID, and get the name from the database The problem is that it works fine, but it takes a lot of time and Excel stops responding. I believe the use of vlookup is what makes my macro to take so long.
Dim Doc_Wkb As Workbook 'Document
Dim DB_Wkb As Workbook 'Database
Set Doc_Wkb = Workbooks.Open(Doc_Path)
Doc_Wkb.Worksheets(Sheet_Name).Cells.Select 'sheet_name=Sheet of the Document
Selection.UnMerge
Doc_Wkb.Worksheets(Sheet_Name).Range("A5:S" & Cells(Rows.Count, "S").End(xlUp).Row).RemoveDuplicates Columns:=16, Header:=xlYes
Set DB_Wkb = Workbooks.Open(DB_Path)
Dim Str As String
Dim Cont_Doc As Double
P = 6 ' P Declared in Module
Cont_DB = DB_Wkb.Worksheets(Sheet_name_2).Range("B:F") ' Sheet_name_2 = sheetname of DB
While Not IsEmpty(Doc_Wkb.Worksheets(Sheet_Name).Cells(P, 5))
Cont_Doc = Doc_Wkb.Worksheets(Sheet_Name).Cells(P, 5)
store = Application.VLookup(Cont_Doc, Cont_DB, 5, False)
Doc_Wkb.Worksheets(Sheet_Name).Cells(P, 20) = store
P = P + 1
Wend
Thank you so much for your help.
Update: I figured out an alternative. Using DoEvents solves this problem. Meanwhile a progress bar can be used for the looks.
I'm working on a macro which will run through the files in the folder and then copy sheets from all excel files to the workbook from which the macro was run.
This part works as charm, what I want to do is to select and copy sheets that match exact name.
For Each wksCurSheet In wbkSrcBook.Sheets
'I reckon I should add some if statement in here
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next
Honestly, I have no idea how to write that statement, examples I found were quite confusing and when I try something by myself, I get weird errors.
If (wksCurSheet.Name == "AO-SC") Then
If (wksCurSheet.Name as String == "AO-SC") Then
If (wksCurSheet.("AO-SC")) Then
What's the correct way?
This is the way to get the specific worksheet through loop:
For Each wksCurSheet In wbkSrcBook.Worksheets
If wksCurSheet.Name = "AO-SC" Then
'Do something
End If
Next
This is how to use it with two worksheets:
If wksCurSheet.Name = "AO-SC" Or wksCurSheet.Name = "SomethingElse" Then
And if the worksheets, you are interestd in are saved in an array, you can use a custom function valueInArray, checking whether the worksheet's name is part of the predefined array:
Public Function valueInArray(myValue As Variant, myArray As Variant) As Boolean
Dim cnt As Long
For cnt = LBound(myArray) To UBound(myArray)
If CStr(myValue) = CStr(myArray(cnt)) Then
valueInArray = True
Exit Function
End If
Next cnt
End Function
This is how to use it:
predefinedArrayWithNames = Array("Sheet1", "Sheet2","Sheet3")
If valueInArray(wksCurSheet.Name, predefinedArrayWithNames) Then
The following code allows me to go through the workbook and worksheets that have macros:
For Each VBCmp In ActiveWorkbook.VBProject.VBComponents
Msgbox VBCmp.Name
Msgbox VBcmp.Type
Next VBCmp
As this page shows, for a workbook and a sheet, their type are both 100, ie, vbext_ct_Document. But I still want to distinguish them: I want to know which VBCmp is about a workbook, which one is about a worksheet.
Note that VBCmp.Name can be changed, they are not necessarily always ThisWorkbook or Sheet1, so it is not a reliable information for what I am after.
Does anyone know if there exists a property about that?
Worksheet objects and Workbook objects both have a CodeName property which will match the VBCmp.Name property, so you can compare the two for a match.
Sub Tester()
Dim vbcmp
For Each vbcmp In ActiveWorkbook.VBProject.VBComponents
Debug.Print vbcmp.Name, vbcmp.Type, _
IIf(vbcmp.Name = ActiveWorkbook.CodeName, "Workbook", "")
Next vbcmp
End Sub
This is the Function I'm using to deal with exported code (VBComponent's method) where I add a preffix to the name of the resulting file. I'm working on an application that will rewrite, among other statements, API Declares, from 32 to 64 bits. I'm planning to abandon XL 32 bits definitely. After exportation I know from where did the codes came from, so I'll rewrite them and put back on the Workbook.
Function fnGetDocumentTypePreffix(ByRef oVBComp As VBIDE.VBComponent) As String
'ALeXceL#Gmail.com
Dim strWB_Date1904 As String
Dim strWS_EnableCalculation As String
Dim strChrt_PlotBy As String
Dim strFRM_Cycle As String
On Error Resume Next
strWB_Date1904 = oVBComp.Properties("Date1904")
strWS_EnableCalculation = oVBComp.Properties("EnableCalculation")
strChrt_PlotBy = oVBComp.Properties("PlotBy")
strFRM_Cycle = oVBComp.Properties("Cycle")
If strWB_Date1904 <> "" Then
fnGetDocumentTypePreffix = "WB_"
ElseIf strWS_EnableCalculation <> "" Then
fnGetDocumentTypePreffix = "WS_"
ElseIf strChrt_PlotBy <> "" Then
fnGetDocumentTypePreffix = "CH_"
ElseIf strFRM_Cycle <> "" Then
fnGetDocumentTypePreffix = "FR_"
Else
Stop 'This isn't expected to happen...
End If
End Function
I have been trying to find a specific data in Excel through a WinForm application and then try to fetch the next value in the same row using vb.net.
Example:
ElementName Value
Age 24
Name John Clan
Music Rock
Suppose if I want to find Age. then I want to make the code return as 24 searching it from Excel file.
I tried pulling the whole Excel data into a Dataset but it wasn't helpful.
Kindly guide me.
Imports Interop = Microsoft.Office.Interop.Excel
'Find In Excel
Private Function FindValueInExcel(ByVal sTextToFind)
Dim currentFind As Interop.Range = Nothing
Dim firstFind As Interop.Range = Nothing
Dim xlappFirstFile As Interop.Application = Nothing
Dim sSearchedValue As String
xlappFirstFile = CreateObject("Excel.Application")
xlappFirstFile.Workbooks.Open("D:\Sample.xlsx")
Dim rngSearchValue As Interop.Range = xlappFirstFile.Range("A1", "C5")
currentFind = rngSearchValue.Find(sTextToFind, , _
Interop.XlFindLookIn.xlValues, Interop.XlLookAt.xlPart, _
Interop.XlSearchOrder.xlByRows, Interop.XlSearchDirection.xlNext, False)
If Not currentFind Is Nothing Then
sSearchedValue = DirectCast(DirectCast(currentFind.EntireRow, Microsoft.Office.Interop.Excel.Range).Value2, System.Object)(1, 3).ToString()
Else
sSearchedValue = ""
End If
Return sSearchedValue
End Function
Link which helped me - http://msdn.microsoft.com/en-us/library/e4x1k99a.aspx?cs-save-lang=1&cs-lang=vb#code-snippet-1
I need to automate the creation of a presentation (either OpenOffice or Powerpoint). The presentation should take the first two slides of each of the presentations in a given directory, and then combine them into a single presentation. I'm confused as to what approach I should take to solve this. Any pointers will be appreciated.
Talking about PowerPoint, you would use a VBA Macro to do the job, something like
Sub Pull()
Dim SrcDir As String, SrcFile As String
SrcDir = PickDir()
If SrcDir = "" Then Exit Sub
SrcFile = Dir(SrcDir & "\*.ppt")
Do While SrcFile <> ""
ImportFromPPT SrcDir + "\" + SrcFile, 1, 2
SrcFile = Dir()
Loop
End Sub
Selecting your source directory you can use this function
Private Function PickDir() As String
Dim FD As FileDialog
PickDir = ""
Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.Title = "Pick a directory to work on"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
PickDir = .SelectedItems(1)
End If
End With
End Function
Now - the main point is inserting slides from another PPT while preserving the source format. This is a tricky thing, as the PPT VBA InsertFromFile method is of no good use. Microsoft gave us good time to figure it out the hard way in countless 20hrs debuging sessions :-) and you need to type a lot of code to get it done correctly - far more complicated than using the dialogue manually, in particular if your source slide deviates from your source master slide.
If your PPT's are sticking to their masters, you can safely omit all code between the ">>>>"
Private Sub ImportFromPPT(FileName As String, SlideFrom As Long, SlideTo As Long)
Dim SrcPPT As Presentation, SrcSld As Slide, Idx As Long, SldCnt As Long
Set SrcPPT = Presentations.Open(FileName, , , msoFalse)
SldCnt = SrcPPT.Slides.Count
If SlideFrom > SldCnt Then Exit Sub
If SlideTo > SldCnt Then SlideTo = SldCnt
For Idx = SlideFrom To SlideTo Step 1
Set SrcSld = SrcPPT.Slides(Idx)
SrcSld.Copy
With ActivePresentation.Slides.Paste
.Design = SrcSld.Design
.ColorScheme = SrcSld.ColorScheme
' if slide is not following its master (design, color scheme)
' we must collect all bits & pieces from the slide itself
' >>>>>>>>>>>>>>>>>>>>
If SrcSld.FollowMasterBackground = False Then
.FollowMasterBackground = False
.Background.Fill.Visible = SrcSld.Background.Fill.Visible
.Background.Fill.ForeColor = SrcSld.Background.Fill.ForeColor
.Background.Fill.BackColor = SrcSld.Background.Fill.BackColor
' inspect the FillType object
Select Case SrcSld.Background.Fill.Type
Case Is = msoFillTextured
Select Case SrcSld.Background.Fill.TextureType
Case Is = msoTexturePreset
.Background.Fill.PresetTextured (SrcSld.Background.Fill.PresetTexture)
Case Is = msoTextureUserDefined
' TextureName gives a filename w/o path
' not implemented, see picture handling
End Select
Case Is = msoFillSolid
.Background.Fill.Transparency = 0#
.Background.Fill.Solid
Case Is = msoFillPicture
' picture cannot be copied directly, need to export and re-import slide image
If SrcSld.Shapes.Count > 0 Then SrcSld.Shapes.Range.Visible = False
bMasterShapes = SrcSld.DisplayMasterShapes
SrcSld.DisplayMasterShapes = False
SrcSld.Export SrcPPT.Path & SrcSld.SlideID & ".png", "PNG"
.Background.Fill.UserPicture SrcPPT.Path & SrcSld.SlideID & ".png"
Kill (SrcPPT.Path & SrcSld.SlideID & ".png")
SrcSld.DisplayMasterShapes = bMasterShapes
If SrcSld.Shapes.Count > 0 Then SrcSld.Shapes.Range.Visible = True
Case Is = msoFillPatterned
.Background.Fill.Patterned (SrcSld.Background.Fill.Pattern)
Case Is = msoFillGradient
' inspect gradient type
Select Case SrcSld.Background.Fill.GradientColorType
Case Is = msoGradientTwoColors
.Background.Fill.TwoColorGradient
SrcSld.Background.Fill.GradientStyle , _
SrcSld.Background.Fill.GradientVariant
Case Is = msoGradientPresetColors
.Background.Fill.PresetGradient _
SrcSld.Background.Fill.GradientStyle, _
SrcSld.Background.Fill.GradientVariant, _
SrcSld.Background.Fill.PresetGradientType
Case Is = msoGradientOneColor
.Background.Fill.OneColorGradient _
SrcSld.Background.Fill.GradientStyle, _
SrcSld.Background.Fill.GradientVariant, _
SrcSld.Background.Fill.GradientDegree
End Select
Case Is = msoFillBackground
' Only shapes - we shouldn't come here
End Select
End If
' >>>>>>>>>>>>>>>>>>>>
End With
Next Idx
End Sub
The code doesn't check for read-only or password protected fies and will crash on them. Also be careful not to run over the collector file itself. Otherwise it should work. I must admit I haven't reviewed the code for a long time ;-)
You can google "powerpoint join" to find a useful tool to join many ppts.
I'm glad #miked was able to get you what you needed.
Another method to consider, if using .NET, is discussed in this post
A simple and fast solution:
I := Presentation.Slides.InsertFromFile(FileName,X,StartSlideNo,EndSlideNo);
Presentation.Slides.Item(I).ApplyTheme(FileName);
Presentation.Slides.Item(I).ApplyTemplate(FileName);
Note:
X is place to insert slide in presentation
I is actual place where slide was inserted
Code is written in Delphi/Pascal but you can convert it easelly ...
You can do this with Aspose.Slides for .NET. It even allows joining OpenOffice and PowerPoint presentations together. View this article.
var presentation1 = new Presentation("presentation1.pptx");
var presentation2 = new Presentation("presentation2.odp");
var mergedPresentation = new Presentation();
while (mergedPresentation.Slides.Count > 0) mergedPresentation.Slides.RemoveAt(0);
// Adding two slides from the first PPTX presentation
mergedPresentation.Slides.AddClone(presentation1.Slides[0]);
mergedPresentation.Slides.AddClone(presentation1.Slides[1]);
// Adding two slides from the second OPD presentation
mergedPresentation.Slides.AddClone(presentation2.Slides[0]);
mergedPresentation.Slides.AddClone(presentation2.Slides[1]);
mergedPresentation.Save("mergedPresentation.pptx", SaveFormat.Pptx);